Change 30678 by [EMAIL PROTECTED] on 2007年03月22日 09:01:37
Subject: [PATCH] Resolve PL_curpm issues with (??{}) and fix corruption
of match results when pattern is a qr.
From: demerphq <[EMAIL PROTECTED]>
Date: 2007年3月21日 10:39:24 +0100
Message-ID: <[EMAIL PROTECTED]>
plus two follow-up patches (minor tweaks)
Affected files ...
... //depot/perl/dump.c#257 edit
... //depot/perl/embed.fnc#471 edit
... //depot/perl/embed.h#672 edit
... //depot/perl/ext/Devel/Peek/t/Peek.t#28 edit
... //depot/perl/ext/Encode/t/Aliases.t#18 edit
... //depot/perl/ext/re/re.pm#48 edit
... //depot/perl/ext/re/t/re_funcs.t#8 edit
... //depot/perl/global.sym#328 edit
... //depot/perl/lib/Tie/Hash/NamedCapture.pm#3 edit
... //depot/perl/pp_ctl.c#605 edit
... //depot/perl/proto.h#808 edit
... //depot/perl/regcomp.c#565 edit
... //depot/perl/regcomp.h#119 edit
... //depot/perl/regexec.c#523 edit
... //depot/perl/regexp.h#92 edit
... //depot/perl/t/op/pat.t#282 edit
... //depot/perl/universal.c#158 edit
Differences ...
==== //depot/perl/dump.c#257 (text) ====
Index: perl/dump.c
--- perl/dump.c#256~30557~ 2007年03月12日 15:14:27.000000000 -0700
+++ perl/dump.c 2007年03月22日 02:01:37.000000000 -0700
@@ -1263,8 +1263,20 @@
Perl_dump_indent(aTHX_ level, file, " MINMATCH\n");
}
if (mg->mg_obj) {
- Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
PTR2UV(mg->mg_obj));
- if (mg->mg_flags & MGf_REFCOUNTED)
+ Perl_dump_indent(aTHX_ level, file, " MG_OBJ = 0x%"UVxf"\n",
+ PTR2UV(mg->mg_obj));
+ if (mg->mg_type == PERL_MAGIC_qr) {
+ regexp *re=(regexp *)mg->mg_obj;
+ SV *dsv= sv_newmortal();
+ const char * const s = pv_pretty(dsv, re->wrapped,
re->wraplen,
+ 60, NULL, NULL,
+ ( PERL_PV_PRETTY_QUOTE | PERL_PV_ESCAPE_RE |
PERL_PV_PRETTY_ELIPSES |
+ ((re->extflags & RXf_UTF8) ? PERL_PV_ESCAPE_UNI : 0))
+ );
+ Perl_dump_indent(aTHX_ level+1, file, " PAT = %s\n", s);
+ Perl_dump_indent(aTHX_ level+1, file, " REFCNT =
%"IVdf"\n", (IV*)re->refcnt);
+ }
+ if (mg->mg_flags & MGf_REFCOUNTED)
do_sv_dump(level+2, file, mg->mg_obj, nest+1, maxnest, dumpops,
pvlim); /* MG is already +1 */
}
if (mg->mg_len)
==== //depot/perl/embed.fnc#471 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc#470~30629~ 2007年03月19日 01:58:08.000000000 -0700
+++ perl/embed.fnc 2007年03月22日 02:01:37.000000000 -0700
@@ -677,6 +677,7 @@
|NN char* strend|NN char* strbeg|I32 minend \
|NN SV* screamer|U32 nosave
Ap |void |pregfree |NULLOK struct regexp* r
+EXp |struct regexp* |reg_temp_copy |NN struct regexp* r
Ap |void |regfree_internal|NULLOK struct regexp* r
Ap |char * |reg_stringify |NN MAGIC *mg|NULLOK STRLEN *lp|NULLOK U32
*flags|NULLOK I32 *haseval
#if defined(USE_ITHREADS)
==== //depot/perl/embed.h#672 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#671~30629~ 2007年03月19日 01:58:08.000000000 -0700
+++ perl/embed.h 2007年03月22日 02:01:37.000000000 -0700
@@ -685,6 +685,9 @@
#define regclass_swash Perl_regclass_swash
#define pregexec Perl_pregexec
#define pregfree Perl_pregfree
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define reg_temp_copy Perl_reg_temp_copy
+#endif
#define regfree_internal Perl_regfree_internal
#define reg_stringify Perl_reg_stringify
#if defined(USE_ITHREADS)
@@ -2906,6 +2909,9 @@
#define regclass_swash(a,b,c,d,e) Perl_regclass_swash(aTHX_ a,b,c,d,e)
#define pregexec(a,b,c,d,e,f,g) Perl_pregexec(aTHX_ a,b,c,d,e,f,g)
#define pregfree(a) Perl_pregfree(aTHX_ a)
+#if defined(PERL_CORE) || defined(PERL_EXT)
+#define reg_temp_copy(a) Perl_reg_temp_copy(aTHX_ a)
+#endif
#define regfree_internal(a) Perl_regfree_internal(aTHX_ a)
#define reg_stringify(a,b,c,d) Perl_reg_stringify(aTHX_ a,b,c,d)
#if defined(USE_ITHREADS)
==== //depot/perl/ext/Devel/Peek/t/Peek.t#28 (text) ====
Index: perl/ext/Devel/Peek/t/Peek.t
--- perl/ext/Devel/Peek/t/Peek.t#27~29693~ 2007年01月05日 01:55:22.000000000
-0800
+++ perl/ext/Devel/Peek/t/Peek.t 2007年03月22日 02:01:37.000000000 -0700
@@ -282,6 +282,8 @@
MG_VIRTUAL = $ADDR
MG_TYPE = PERL_MAGIC_qr\(r\)
MG_OBJ = $ADDR
+ PAT = "\(\?-xism:tic\)"
+ REFCNT = 2
STASH = $ADDR\\t"Regexp"');
do_test(16,
==== //depot/perl/ext/Encode/t/Aliases.t#18 (text) ====
Index: perl/ext/Encode/t/Aliases.t
--- perl/ext/Encode/t/Aliases.t#17~28098~ 2006年05月04日 05:06:33.000000000
-0700
+++ perl/ext/Encode/t/Aliases.t 2007年03月22日 02:01:37.000000000 -0700
@@ -122,6 +122,7 @@
print "# alias test; \$ON_EBCDIC == $ON_EBCDIC\n";
foreach my $a (keys %a2c){
+ print "# $a => $a2c{$a}\n";
my $e = Encode::find_encoding($a);
is((defined($e) and $e->name), $a2c{$a},$a)
or warn "alias was $a";;
==== //depot/perl/ext/re/re.pm#48 (text) ====
Index: perl/ext/re/re.pm
--- perl/ext/re/re.pm#47~30436~ 2007年03月01日 02:54:09.000000000 -0800
+++ perl/ext/re/re.pm 2007年03月22日 02:01:37.000000000 -0700
@@ -473,45 +473,39 @@
are using thinks is the longest. If you believe that the result is wrong
please report it via the L<perlbug> utility.
-=item regname($name,$qr,$all)
+=item regname($name,$all)
-Returns the contents of a named buffer. If $qr is missing, or is not the
-result of a qr// then returns the result of the last successful match. If
-$all is true then returns an array ref containing one entry per buffer,
+Returns the contents of a named buffer of the last successful match. If
+$all is true, then returns an array ref containing one entry per buffer,
otherwise returns the first defined buffer.
-=item regnames($qr,$all)
+=item regnames($all)
-Returns a list of all of the named buffers defined in a pattern. If
-$all is true then it returns all names defined, if not returns only
-names which were involved in the last successful match. If $qr is omitted
-or is not the result of a qr// then returns the details for the last
-successful match.
+Returns a list of all of the named buffers defined in the last successful
+match. If $all is true, then it returns all names defined, if not it returns
+only names which were involved in the match.
-=item regnames_iterinit($qr)
+=item regnames_iterinit()
-Initializes the internal hash iterator associated to a regexps named capture
-buffers. If $qr is omitted resets the iterator associated with the regexp used
-in the last successful match.
+Initializes the internal hash iterator associated to the last successful
+matches named capture buffers.
-=item regnames_iternext($qr,$all)
+=item regnames_iternext($all)
-Gets the next key from the hash associated with a regexp. If $qr
-is omitted resets the iterator associated with the regexp used in the
-last successful match. If $all is true returns the keys of all of the
+Gets the next key from the named capture buffer hash associated with the
+last successful match. If $all is true returns the keys of all of the
distinct named buffers in the pattern, if not returns only those names
used in the last successful match.
-=item regnames_count($qr)
+=item regnames_count()
-Returns the number of distinct names defined in the regexp $qr. If
-$qr is omitted or not a regexp returns the count of names in the
-last successful match.
-
-B<Note:> that this result is always the actual number of distinct
-named buffers defined, it may not actually match that which is
-returned by C<regnames()> and related routines when those routines
-have not been called with the $all parameter set..
+Returns the number of distinct names defined in the pattern used
+for the last successful match.
+
+B<Note:> this result is always the actual number of distinct
+named buffers defined, it may not actually match that which is
+returned by C<regnames()> and related routines when those routines
+have not been called with the $all parameter set.
=back
==== //depot/perl/ext/re/t/re_funcs.t#8 (text) ====
Index: perl/ext/re/t/re_funcs.t
--- perl/ext/re/t/re_funcs.t#7~30517~ 2007年03月08日 07:06:49.000000000 -0800
+++ perl/ext/re/t/re_funcs.t 2007年03月22日 02:01:37.000000000 -0700
@@ -42,19 +42,14 @@
if ('1234'=~/(?:(?<A>\d)|(?<C>!))(?<B>\d)(?<A>\d)(?<B>\d)/){
- my $qr = qr/(?<foo>foo)(?<bar>bar)/;
- my @names = sort +regnames($qr);
- is("@names","","regnames");
- @names = sort +regnames($qr,1);
- is("@names","bar foo","regnames - all");
- @names = sort +regnames();
+ my @names = sort +regnames();
is("@names","A B","regnames");
- @names = sort +regnames(undef,1);
+ @names = sort +regnames(1);
is("@names","A B C","regnames");
- is(join("", @{regname("A",undef,1)}),"13");
- is(join("", @{regname("B",undef,1)}),"24");
+ is(join("", @{regname("A",1)}),"13");
+ is(join("", @{regname("B",1)}),"24");
{
- if ('foobar'=~/$qr/) {
+ if ('foobar'=~/(?<foo>foo)(?<bar>bar)/) {
regnames_iterinit();
my @res;
while (defined(my $key=regnames_iternext)) {
@@ -68,20 +63,7 @@
}
}
is(regnames_count(),3);
- is(regnames_count($qr),2);
-}
-{
- use warnings;
- require Tie::Hash::NamedCapture;
- my $qr = qr/(?<foo>foo)/;
- if ( 'foo' =~ /$qr/ ) {
- tie my %hash,"Tie::Hash::NamedCapture",re => $qr;
- if ('bar'=~/bar/) {
- # last successful match is now different
- is($hash{foo},'foo'); # prints foo
- }
- }
}
# New tests above this line, don't forget to update the test count below!
-use Test::More tests => 23;
+use Test::More tests => 19;
# No tests here!
==== //depot/perl/global.sym#328 (text+w) ====
Index: perl/global.sym
--- perl/global.sym#327~30552~ 2007年03月12日 08:30:39.000000000 -0700
+++ perl/global.sym 2007年03月22日 02:01:37.000000000 -0700
@@ -390,6 +390,7 @@
Perl_regclass_swash
Perl_pregexec
Perl_pregfree
+Perl_reg_temp_copy
Perl_regfree_internal
Perl_reg_stringify
Perl_regdupe_internal
==== //depot/perl/lib/Tie/Hash/NamedCapture.pm#3 (text) ====
Index: perl/lib/Tie/Hash/NamedCapture.pm
--- perl/lib/Tie/Hash/NamedCapture.pm#2~30518~ 2007年03月08日 07:48:53.000000000
-0800
+++ perl/lib/Tie/Hash/NamedCapture.pm 2007年03月22日 02:01:37.000000000 -0700
@@ -3,27 +3,18 @@
use strict;
use warnings;
-our $VERSION = "0.04";
+our $VERSION = "0.05";
sub TIEHASH {
my $classname = shift;
my %opts = @_;
- if ($opts{re} && !re::is_regexp($opts{re})) {
- require Carp;
- Carp::croak("'re' parameter to " . __PACKAGE__
- . "->TIEHASH must be a qr//.");
- }
-
- my $self = bless {
- all => $opts{all},
- re => $opts{re},
- }, $classname;
+ my $self = bless { all => $opts{all} }, $classname;
return $self;
}
sub FETCH {
- return re::regname($_[1],$_[0]->{re},$_[0]->{all});
+ return re::regname($_[1],$_[0]->{all});
}
sub STORE {
@@ -32,16 +23,16 @@
}
sub FIRSTKEY {
- re::regnames_iterinit($_[0]->{re});
+ re::regnames_iterinit();
return $_[0]->NEXTKEY;
}
sub NEXTKEY {
- return re::regnames_iternext($_[0]->{re},$_[0]->{all});
+ return re::regnames_iternext($_[0]->{all});
}
sub EXISTS {
- return defined re::regname( $_[1], $_[0]->{re},$_[0]->{all});
+ return defined re::regname( $_[1], $_[0]->{all});
}
sub DELETE {
@@ -55,7 +46,7 @@
}
sub SCALAR {
- return scalar re::regnames($_[0]->{re},$_[0]->{all});
+ return scalar re::regnames($_[0]->{all});
}
tie %+, __PACKAGE__;
@@ -74,19 +65,13 @@
tie my %hash, "Tie::Hash::NamedCapture";
# %hash now behaves like %+
- tie my %hash, "Tie::Hash::NamedCapture", re => $qr, all => 1;
+ tie my %hash, "Tie::Hash::NamedCapture", all => 1;
# %hash now access buffers from regexp in $qr like %-
=head1 DESCRIPTION
This module is used to implement the special hashes C<%+> and C<%->, but it
-can be used independently.
-
-When the C<re> parameter is set to a C<qr//> expression, then the tied
-hash is bound to that particular regexp and will return the results of its
-last successful match. If the parameter is omitted, then the hash behaves
-just as C<1ドル> does by referencing the last successful match in the
-currently active dynamic scope.
+can be used to tie other variables as you choose.
When the C<all> parameter is provided, then the tied hash elements will be
array refs listing the contents of each capture buffer whose name is the
@@ -104,20 +89,6 @@
regular expression; the keys of C<%+>-like hashes list only the names of
buffers that have captured (and that are thus associated to defined values).
-For instance:
-
- my $qr = qr/(?<foo>bar)/;
- if ( 'bar' =~ $qr ) {
- tie my %hash, "Tie::Hash::NamedCapture", re => $qr;
- print $+{foo}; # prints "bar"
- print $hash{foo}; # prints "bar" too
- if ( 'bar' =~ /bar/ ) {
- # last successful match is now different
- print $+{foo}; # prints nothing (undef)
- print $hash{foo}; # still prints "bar"
- }
- }
-
=head1 SEE ALSO
L<re>, L<perlmodlib/Pragmatic Modules>, L<perlvar/"%+">, L<perlvar/"%-">.
==== //depot/perl/pp_ctl.c#605 (text) ====
Index: perl/pp_ctl.c
--- perl/pp_ctl.c#604~30629~ 2007年03月19日 01:58:08.000000000 -0700
+++ perl/pp_ctl.c 2007年03月22日 02:01:37.000000000 -0700
@@ -118,9 +118,9 @@
mg = mg_find(sv, PERL_MAGIC_qr);
}
if (mg) {
- regexp * const re = (regexp *)mg->mg_obj;
+ regexp * const re = reg_temp_copy((regexp *)mg->mg_obj);
ReREFCNT_dec(PM_GETRE(pm));
- PM_SETRE(pm, ReREFCNT_inc(re));
+ PM_SETRE(pm, re);
}
else {
STRLEN len;
==== //depot/perl/proto.h#808 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#807~30629~ 2007年03月19日 01:58:08.000000000 -0700
+++ perl/proto.h 2007年03月22日 02:01:37.000000000 -0700
@@ -1853,6 +1853,9 @@
__attribute__nonnull__(pTHX_6);
PERL_CALLCONV void Perl_pregfree(pTHX_ struct regexp* r);
+PERL_CALLCONV struct regexp* Perl_reg_temp_copy(pTHX_ struct regexp* r)
+ __attribute__nonnull__(pTHX_1);
+
PERL_CALLCONV void Perl_regfree_internal(pTHX_ struct regexp* r);
PERL_CALLCONV char * Perl_reg_stringify(pTHX_ MAGIC *mg, STRLEN *lp, U32
*flags, I32 *haseval)
__attribute__nonnull__(pTHX_1);
==== //depot/perl/regcomp.c#565 (text) ====
Index: perl/regcomp.c
--- perl/regcomp.c#564~30647~ 2007年03月20日 02:01:05.000000000 -0700
+++ perl/regcomp.c 2007年03月22日 02:01:37.000000000 -0700
@@ -4183,7 +4183,7 @@
+ (sizeof(STD_PAT_MODS) - 1)
+ (sizeof("(?:)") - 1);
- Newx(r->wrapped, r->wraplen, char );
+ Newx(r->wrapped, r->wraplen + 1, char );
p = r->wrapped;
*p++='('; *p++='?';
if (has_k)
@@ -4206,13 +4206,14 @@
}
}
- *p++=':';
+ *p++ = ':';
Copy(RExC_precomp, p, r->prelen, char);
r->precomp = p;
p += r->prelen;
if (has_runon)
- *p++='\n';
- *p=')';
+ *p++ = '\n';
+ *p++ = ')';
+ *p = 0;
}
r->intflags = 0;
@@ -8665,31 +8666,93 @@
if (!r || (--r->refcnt > 0))
return;
-
- CALLREGFREE_PVT(r); /* free the private data */
+ if (r->mother_re) {
+ ReREFCNT_dec(r->mother_re);
+ } else {
+ CALLREGFREE_PVT(r); /* free the private data */
+ if (r->paren_names)
+ SvREFCNT_dec(r->paren_names);
+ Safefree(r->wrapped);
+ }
+ if (r->substrs) {
+ if (r->anchored_substr)
+ SvREFCNT_dec(r->anchored_substr);
+ if (r->anchored_utf8)
+ SvREFCNT_dec(r->anchored_utf8);
+ if (r->float_substr)
+ SvREFCNT_dec(r->float_substr);
+ if (r->float_utf8)
+ SvREFCNT_dec(r->float_utf8);
+ Safefree(r->substrs);
+ }
RX_MATCH_COPY_FREE(r);
#ifdef PERL_OLD_COPY_ON_WRITE
if (r->saved_copy)
- SvREFCNT_dec(r->saved_copy);
+ SvREFCNT_dec(r->saved_copy);
#endif
- if (r->substrs) {
- if (r->anchored_substr)
- SvREFCNT_dec(r->anchored_substr);
- if (r->anchored_utf8)
- SvREFCNT_dec(r->anchored_utf8);
- if (r->float_substr)
- SvREFCNT_dec(r->float_substr);
- if (r->float_utf8)
- SvREFCNT_dec(r->float_utf8);
- Safefree(r->substrs);
+ if (r->swap) {
+ Safefree(r->swap->startp);
+ Safefree(r->swap->endp);
+ Safefree(r->swap);
}
- if (r->paren_names)
- SvREFCNT_dec(r->paren_names);
- Safefree(r->wrapped);
Safefree(r->startp);
Safefree(r->endp);
Safefree(r);
}
+
+/* reg_temp_copy()
+
+ This is a hacky workaround to the structural issue of match results
+ being stored in the regexp structure which is in turn stored in
+ PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
+ could be PL_curpm in multiple contexts, and could require multiple
+ result sets being associated with the pattern simultaneously, such
+ as when doing a recursive match with (??{$qr})
+
+ The solution is to make a lightweight copy of the regexp structure
+ when a qr// is returned from the code executed by (??{$qr}) this
+ lightweight copy doesnt actually own any of its data except for
+ the starp/end and the actual regexp structure itself.
+
+*/
+
+
+regexp *
+Perl_reg_temp_copy (pTHX_ struct regexp *r) {
+ regexp *ret;
+ register const I32 npar = r->nparens+1;
+ (void)ReREFCNT_inc(r);
+ Newx(ret, 1, regexp);
+ StructCopy(r, ret, regexp);
+ Newx(ret->startp, npar, I32);
+ Copy(r->startp, ret->startp, npar, I32);
+ Newx(ret->endp, npar, I32);
+ Copy(r->endp, ret->endp, npar, I32);
+ ret->refcnt = 1;
+ if (r->substrs) {
+ struct reg_substr_datum *s;
+ I32 i;
+ Newx(ret->substrs, 1, struct reg_substr_data);
+ for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
+ s->min_offset = r->substrs->data[i].min_offset;
+ s->max_offset = r->substrs->data[i].max_offset;
+ s->end_shift = r->substrs->data[i].end_shift;
+ s->substr = SvREFCNT_inc(r->substrs->data[i].substr);
+ s->utf8_substr = SvREFCNT_inc(r->substrs->data[i].utf8_substr);
+ }
+ }
+ RX_MATCH_COPIED_off(ret);
+#ifdef PERL_OLD_COPY_ON_WRITE
+ /* this is broken. */
+ assert(0);
+ if (ret->saved_copy)
+ ret->saved_copy=NULL;
+#endif
+ ret->mother_re = r;
+ ret->swap = NULL;
+
+ return ret;
+}
#endif
/* regfree_internal()
@@ -8814,11 +8877,7 @@
Safefree(ri->data->what);
Safefree(ri->data);
}
- if (ri->swap) {
- Safefree(ri->swap->startp);
- Safefree(ri->swap->endp);
- Safefree(ri->swap);
- }
+
Safefree(ri);
}
@@ -8848,7 +8907,7 @@
{
dVAR;
regexp *ret;
- int i, npar;
+ I32 i, npar;
struct reg_substr_datum *s;
if (!r)
@@ -8864,6 +8923,14 @@
Copy(r->startp, ret->startp, npar, I32);
Newx(ret->endp, npar, I32);
Copy(r->endp, ret->endp, npar, I32);
+ if(r->swap) {
+ Newx(ret->swap, 1, regexp_paren_ofs);
+ /* no need to copy these */
+ Newx(ret->swap->startp, npar, I32);
+ Newx(ret->swap->endp, npar, I32);
+ } else {
+ ret->swap = NULL;
+ }
if (r->substrs) {
Newx(ret->substrs, 1, struct reg_substr_data);
@@ -8877,11 +8944,12 @@
} else
ret->substrs = NULL;
- ret->wrapped = SAVEPVN(r->wrapped, r->wraplen);
+ ret->wrapped = SAVEPVN(r->wrapped, r->wraplen+1);
ret->precomp = ret->wrapped + (r->precomp - r->wrapped);
ret->prelen = r->prelen;
ret->wraplen = r->wraplen;
+ ret->mother_re = NULL;
ret->refcnt = r->refcnt;
ret->minlen = r->minlen;
ret->minlenret = r->minlenret;
@@ -8942,14 +9010,6 @@
Newxc(reti, sizeof(regexp_internal) + (len+1)*sizeof(regnode), char,
regexp_internal);
Copy(ri->program, reti->program, len+1, regnode);
- if(ri->swap) {
- Newx(reti->swap, 1, regexp_paren_ofs);
- /* no need to copy these */
- Newx(reti->swap->startp, npar, I32);
- Newx(reti->swap->endp, npar, I32);
- } else {
- reti->swap = NULL;
- }
reti->regstclass = NULL;
==== //depot/perl/regcomp.h#119 (text) ====
Index: perl/regcomp.h
--- perl/regcomp.h#118~30436~ 2007年03月01日 02:54:09.000000000 -0800
+++ perl/regcomp.h 2007年03月22日 02:01:37.000000000 -0700
@@ -101,11 +101,7 @@
/* This is the stuff that used to live in regexp.h that was truly
private to the engine itself. It now lives here. */
-/* swap buffer for paren structs */
-typedef struct regexp_paren_ofs {
- I32 *startp;
- I32 *endp;
-} regexp_paren_ofs;
+
typedef struct regexp_internal {
int name_list_idx; /* Optional data index of an array of paren
names */
@@ -118,7 +114,6 @@
U32 proglen;
} u;
- regexp_paren_ofs *swap; /* Swap copy of *startp / *endp */
regnode *regstclass; /* Optional startclass as identified or
constructed
by the optimiser */
struct reg_data *data; /* Additional miscellaneous data used by the
program.
==== //depot/perl/regexec.c#523 (text) ====
Index: perl/regexec.c
--- perl/regexec.c#522~30647~ 2007年03月20日 02:01:05.000000000 -0700
+++ perl/regexec.c 2007年03月22日 02:01:37.000000000 -0700
@@ -1652,9 +1652,8 @@
static void
S_swap_match_buff (pTHX_ regexp *prog) {
I32 *t;
- RXi_GET_DECL(prog,progi);
- if (!progi->swap) {
+ if (!prog->swap) {
/* We have to be careful. If the previous successful match
was from this regex we don't want a subsequent paritally
successful match to clobber the old results.
@@ -1662,16 +1661,16 @@
to the re, and switch the buffer each match. If we fail
we switch it back, otherwise we leave it swapped.
*/
- Newxz(progi->swap, 1, regexp_paren_ofs);
+ Newxz(prog->swap, 1, regexp_paren_ofs);
/* no need to copy these */
- Newxz(progi->swap->startp, prog->nparens + 1, I32);
- Newxz(progi->swap->endp, prog->nparens + 1, I32);
+ Newxz(prog->swap->startp, prog->nparens + 1, I32);
+ Newxz(prog->swap->endp, prog->nparens + 1, I32);
}
- t = progi->swap->startp;
- progi->swap->startp = prog->startp;
+ t = prog->swap->startp;
+ prog->swap->startp = prog->startp;
prog->startp = t;
- t = progi->swap->endp;
- progi->swap->endp = prog->endp;
+ t = prog->swap->endp;
+ prog->swap->endp = prog->endp;
prog->endp = t;
}
@@ -2611,6 +2610,10 @@
return 0;
}
+#define SETREX(Re1,Re2) \
+ if (PL_reg_eval_set) PM_SETRE((PL_reg_curpm), (Re2)); \
+ Re1 = (Re2)
+
STATIC I32 /* 0 failure, 1 success */
S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
{
@@ -3654,8 +3657,7 @@
}
if (mg) {
- re = (regexp *)mg->mg_obj;
- (void)ReREFCNT_inc(re);
+ re = reg_temp_copy((regexp *)mg->mg_obj); /*XXX:dmq*/
}
else {
STRLEN len;
@@ -3674,6 +3676,9 @@
PL_regsize = osize;
}
}
+ RX_MATCH_COPIED_off(re);
+ re->subbeg = rex->subbeg;
+ re->sublen = rex->sublen;
rei = RXi_GET(re);
DEBUG_EXECUTE_r(
debug_start_match(re, do_utf8, locinput, PL_regeol,
@@ -3715,7 +3720,7 @@
ST.prev_rex = rex;
ST.prev_curlyx = cur_curlyx;
- rex = re;
+ SETREX(rex,re);
rexi = rei;
cur_curlyx = NULL;
ST.B = next;
@@ -3735,7 +3740,7 @@
/* note: this is called twice; first after popping B, then A */
PL_reg_flags ^= ST.toggle_reg_flags;
ReREFCNT_dec(rex);
- rex = ST.prev_rex;
+ SETREX(rex,ST.prev_rex);
rexi = RXi_GET(rex);
regcpblow(ST.cp);
cur_eval = ST.prev_eval;
@@ -3751,7 +3756,7 @@
/* note: this is called twice; first after popping B, then A */
PL_reg_flags ^= ST.toggle_reg_flags;
ReREFCNT_dec(rex);
- rex = ST.prev_rex;
+ SETREX(rex,ST.prev_rex);
rexi = RXi_GET(rex);
PL_reginput = locinput;
REGCP_UNWIND(ST.lastcp);
@@ -4760,7 +4765,7 @@
PL_reg_flags ^= st->u.eval.toggle_reg_flags;
st->u.eval.prev_rex = rex; /* inner */
- rex = cur_eval->u.eval.prev_rex; /* outer */
+ SETREX(rex,cur_eval->u.eval.prev_rex);
rexi = RXi_GET(rex);
cur_curlyx = cur_eval->u.eval.prev_curlyx;
ReREFCNT_inc(rex);
==== //depot/perl/regexp.h#92 (text) ====
Index: perl/regexp.h
--- perl/regexp.h#91~30412~ 2007年02月26日 08:49:45.000000000 -0800
+++ perl/regexp.h 2007年03月22日 02:01:37.000000000 -0700
@@ -31,6 +31,7 @@
struct reg_data;
struct regexp_engine;
+struct regexp;
struct reg_substr_datum {
I32 min_offset;
@@ -48,11 +49,19 @@
#else
#define SV_SAVED_COPY
#endif
+
+/* swap buffer for paren structs */
+typedef struct regexp_paren_ofs {
+ I32 *startp;
+ I32 *endp;
+} regexp_paren_ofs;
+
/* this is ordered such that the most commonly used
fields are at the start of the struct */
typedef struct regexp {
/* what engine created this regexp? */
const struct regexp_engine* engine;
+ struct regexp* mother_re; /* what re is this a lightweight copy of? */
/* Information about the match that the perl core uses to manage things
*/
U32 extflags; /* Flags used both externally and internally */
@@ -71,8 +80,10 @@
/* Data about the last/current match. These are modified during
matching*/
U32 lastparen; /* last open paren matched */
U32 lastcloseparen; /* last close paren matched */
+ regexp_paren_ofs *swap; /* Swap copy of *startp / *endp */
I32 *startp; /* Array of offsets from start of string (@-)
*/
I32 *endp; /* Array of offsets from start of string (@+) */
+
char *subbeg; /* saved or original string
so \digit works forever. */
I32 sublen; /* Length of string pointed by subbeg */
@@ -216,7 +227,6 @@
#define RXf_TAINTED_SEEN 0x20000000
/* two bits here */
-
#define RX_HAS_CUTGROUP(prog) ((prog)->intflags & PREGf_CUTGROUP_SEEN)
#define RX_MATCH_TAINTED(prog) ((prog)->extflags & RXf_TAINTED_SEEN)
#define RX_MATCH_TAINTED_on(prog) ((prog)->extflags |= RXf_TAINTED_SEEN)
==== //depot/perl/t/op/pat.t#282 (xtext) ====
Index: perl/t/op/pat.t
--- perl/t/op/pat.t#281~30647~ 2007年03月20日 02:01:05.000000000 -0700
+++ perl/t/op/pat.t 2007年03月22日 02:01:37.000000000 -0700
@@ -4267,11 +4267,11 @@
$re = qr/^ ( (??{ $grabit }) ) $ /x;
my @res = '0902862349' =~ $re;
iseq(join("-",@res),"0902862349",
- 'PL_curpm is set properly on nested eval # TODO');
+ 'PL_curpm is set properly on nested eval');
our $qr = qr/ (o) (??{ 1ドル }) /x;
ok( 'boob'=~/( b (??{ $qr }) b )/x && 1,
- "PL_curpm, nested eval # TODO");
+ "PL_curpm, nested eval");
}
{
@@ -4325,7 +4325,17 @@
ok($c=~/${c}|\x{100}/);
ok(@w==0);
}
-
+{
+ local $Message = "corruption of match results of qr// across scopes";
+ my $qr=qr/(fo+)(ba+r)/;
+ 'foobar'=~/$qr/;
+ iseq("1ドル2ドル","foobar");
+ {
+ 'foooooobaaaaar'=~/$qr/;
+ iseq("1ドル2ドル",'foooooobaaaaar');
+ }
+ iseq("1ドル2ドル","foobar");
+}
# Test counter is at bottom of file. Put new tests above here.
#-------------------------------------------------------------------
# Keep the following tests last -- they may crash perl
@@ -4395,7 +4405,7 @@
iseq(0+$::test,$::TestCount,"Got the right number of tests!");
# Don't forget to update this!
BEGIN {
- $::TestCount = 1652;
+ $::TestCount = 1655;
print "1..$::TestCount\n";
}
==== //depot/perl/universal.c#158 (text) ====
Index: perl/universal.c
--- perl/universal.c#157~30629~ 2007年03月19日 01:58:08.000000000 -0700
+++ perl/universal.c 2007年03月22日 02:01:37.000000000 -0700
@@ -333,11 +333,11 @@
newXSproto("Internals::inc_sub_generation",XS_Internals_inc_sub_generation,
file, "");
newXSproto("re::is_regexp", XS_re_is_regexp, file, "$");
- newXSproto("re::regname", XS_re_regname, file, ";$$$");
- newXSproto("re::regnames", XS_re_regnames, file, ";$$");
- newXSproto("re::regnames_iterinit", XS_re_regnames_iterinit, file, ";$");
- newXSproto("re::regnames_iternext", XS_re_regnames_iternext, file, ";$$");
- newXSproto("re::regnames_count", XS_re_regnames_count, file, ";$");
+ newXSproto("re::regname", XS_re_regname, file, ";$$");
+ newXSproto("re::regnames", XS_re_regnames, file, ";$");
+ newXSproto("re::regnames_iterinit", XS_re_regnames_iterinit, file, "");
+ newXSproto("re::regnames_iternext", XS_re_regnames_iternext, file, ";$");
+ newXSproto("re::regnames_count", XS_re_regnames_count, file, "");
}
@@ -1143,31 +1143,23 @@
dVAR;
dXSARGS;
- if (items < 1 || items > 3)
- Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "sv, qr = NULL, all =
NULL");
+ if (items < 1 || items > 2)
+ Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "name[, all ]");
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(ax); /* -Wall */
SP -= items;
{
SV * sv = ST(0);
- SV * qr;
SV * all;
- regexp *re = NULL;
+ regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
SV *bufs = NULL;
if (items < 2)
- qr = NULL;
- else {
- qr = ST(1);
- }
-
- if (items < 3)
all = NULL;
else {
- all = ST(2);
+ all = ST(1);
}
{
- re = Perl_get_re_arg( aTHX_ qr, 1, NULL);
if (SvPOK(sv) && re && re->paren_names) {
bufs = CALLREG_NAMEDBUF(re,sv,all && SvTRUE(all));
if (bufs) {
@@ -1189,30 +1181,22 @@
{
dVAR;
dXSARGS;
- if (items < 0 || items > 2)
- Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "sv = NULL, all =
NULL");
+ if (items < 0 || items > 1)
+ Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "[all]");
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(ax); /* -Wall */
SP -= items;
{
- SV * sv;
SV * all;
- regexp *re = NULL;
+ regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
IV count = 0;
if (items < 1)
- sv = NULL;
- else {
- sv = ST(0);
- }
-
- if (items < 2)
all = NULL;
else {
- all = ST(1);
+ all = ST(0);
}
{
- re = Perl_get_re_arg( aTHX_ sv, 1, NULL );
if (re && re->paren_names) {
HV *hv= re->paren_names;
(void)hv_iterinit(hv);
@@ -1259,29 +1243,19 @@
{
dVAR;
dXSARGS;
- if (items < 0 || items > 1)
- Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iterinit", "sv = NULL");
+ if (items != 0 )
+ Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iterinit");
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(ax); /* -Wall */
SP -= items;
{
- SV * sv;
- regexp *re = NULL;
-
- if (items < 1)
- sv = NULL;
- else {
- sv = ST(0);
- }
- {
- re = Perl_get_re_arg( aTHX_ sv, 1, NULL );
- if (re && re->paren_names) {
- (void)hv_iterinit(re->paren_names);
- XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
- } else {
- XSRETURN_UNDEF;
- }
- }
+ regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
+ if (re && re->paren_names) {
+ (void)hv_iterinit(re->paren_names);
+ XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
+ } else {
+ XSRETURN_UNDEF;
+ }
PUTBACK;
return;
}
@@ -1292,60 +1266,50 @@
{
dVAR;
dXSARGS;
- if (items < 0 || items > 2)
- Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iternext", "sv = NULL,
all = NULL");
+ if (items < 0 || items > 1)
+ Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iternext", "[all]");
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(ax); /* -Wall */
SP -= items;
{
- SV * sv;
SV * all;
- regexp *re;
+ regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
if (items < 1)
- sv = NULL;
- else {
- sv = ST(0);
- }
-
- if (items < 2)
all = NULL;
else {
- all = ST(1);
+ all = ST(0);
}
- {
- re = Perl_get_re_arg( aTHX_ sv, 1, NULL );
- if (re && re->paren_names) {
- HV *hv= re->paren_names;
- while (1) {
- HE *temphe = hv_iternext_flags(hv,0);
- if (temphe) {
- IV i;
- IV parno = 0;
- SV* sv_dat = HeVAL(temphe);
- I32 *nums = (I32*)SvPVX(sv_dat);
- for ( i = 0; i < SvIVX(sv_dat); i++ ) {
- if ((I32)(re->lastcloseparen) >= nums[i] &&
- re->startp[nums[i]] != -1 &&
- re->endp[nums[i]] != -1)
- {
- parno = nums[i];
- break;
- }
- }
- if (parno || (all && SvTRUE(all))) {
- STRLEN len;
- char *pv = HePV(temphe, len);
- XPUSHs(newSVpvn(pv,len));
- XSRETURN(1);
+ if (re && re->paren_names) {
+ HV *hv= re->paren_names;
+ while (1) {
+ HE *temphe = hv_iternext_flags(hv,0);
+ if (temphe) {
+ IV i;
+ IV parno = 0;
+ SV* sv_dat = HeVAL(temphe);
+ I32 *nums = (I32*)SvPVX(sv_dat);
+ for ( i = 0; i < SvIVX(sv_dat); i++ ) {
+ if ((I32)(re->lastcloseparen) >= nums[i] &&
+ re->startp[nums[i]] != -1 &&
+ re->endp[nums[i]] != -1)
+ {
+ parno = nums[i];
+ break;
}
- } else {
- break;
}
+ if (parno || (all && SvTRUE(all))) {
+ STRLEN len;
+ char *pv = HePV(temphe, len);
+ XPUSHs(newSVpvn(pv,len));
+ XSRETURN(1);
+ }
+ } else {
+ break;
}
}
- XSRETURN_UNDEF;
- }
+ }
+ XSRETURN_UNDEF;
PUTBACK;
return;
}
@@ -1354,22 +1318,16 @@
XS(XS_re_regnames_count)
{
- SV * sv;
- regexp *re = NULL;
+ regexp *re = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
dVAR;
dXSARGS;
- if (items < 0 || items > 1)
- Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "sv = NULL");
+ if (items != 0)
+ Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "");
PERL_UNUSED_VAR(cv); /* -W */
PERL_UNUSED_VAR(ax); /* -Wall */
SP -= items;
- if (items < 1)
- sv = NULL;
- else {
- sv = ST(0);
- }
- re = Perl_get_re_arg( aTHX_ sv, 1, NULL );
+
if (re && re->paren_names) {
XPUSHs(newSViv(HvTOTALKEYS(re->paren_names)));
} else {
End of Patch.