This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make /(?p:...)/ keep RXf_PMf_KEEPCOPY flag
authorDavid Mitchell <davem@iabyn.com>
Mon, 6 May 2013 11:14:26 +0000 (12:14 +0100)
committerDavid Mitchell <davem@iabyn.com>
Mon, 6 May 2013 11:22:30 +0000 (12:22 +0100)
RT #117135

The /p flag, when used internally within a pattern, isn't like the
other internal patterns, e.g. (?i:...), in that once seen, the
pattern should have the RXf_PMf_KEEPCOPY flag globally set and not
just enabled within the scope of the (?p:...).

regcomp.c
t/re/reg_pmod.t

index d1bdf44..de17958 100644 (file)
--- a/regcomp.c
+++ b/regcomp.c
@@ -9456,7 +9456,8 @@ S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
 
     /* Check for proper termination. */
     if (paren) {
-       RExC_flags = oregflags;
+        /* restore original flags, but keep (?p) */
+       RExC_flags = oregflags | (RExC_flags & RXf_PMf_KEEPCOPY);
        if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
            RExC_parse = oregcomp_parse;
            vFAIL("Unmatched (");
index 3190e03..a766a69 100644 (file)
@@ -13,11 +13,12 @@ our @tests = (
     # /p      Pattern   PRE     MATCH   POST
     [ '/p',   "345",    "12-", "345",  "-6789"],
     [ '(?p)', "345",    "12-", "345",  "-6789"],
+    [ '(?p:)',"345",    "12-", "345",  "-6789"],
     [ '',     "(345)",  undef,  undef,  undef ],
     [ '',     "345",    undef,  undef,  undef ],
 );
 
-plan tests => 14 * @tests + 2;
+plan tests => 14 * @tests + 4;
 my $W = "";
 
 $SIG{__WARN__} = sub { $W.=join("",@_); };
@@ -28,6 +29,7 @@ foreach my $test (@tests) {
     for my $sub (0,1) {
        my $test_name = $p eq '/p'   ? "/$pat/p"
                      : $p eq '(?p)' ? "/(?p)$pat/"
+                     : $p eq '(?p:)'? "/(?p:$pat)/"
                      :                "/$pat/";
        $test_name = "s$test_name" if $sub;
 
@@ -39,11 +41,13 @@ foreach my $test (@tests) {
                $sub ?
                        (   $p eq '/p'   ? s/$pat/abc/p
                          : $p eq '(?p)' ? s/(?p)$pat/abc/
+                         : $p eq '(?p:)'? s/(?p:$pat)/abc/
                          :                s/$pat/abc/
                        )
                     :
                        (   $p eq '/p'   ? /$pat/p
                          : $p eq '(?p)' ? /(?p)$pat/
+                         : $p eq '(?p:)'? /(?p:$pat)/
                          :                /$pat/
                        );
        ok $ok, $test_name;
@@ -61,3 +65,11 @@ foreach my $test (@tests) {
 }
 is($W,"","No warnings should be produced");
 ok(!defined ${^MATCH}, "No /p in scope so ^MATCH is undef");
+
+#RT 117135
+
+{
+    my $m;
+    ok("a"=~ /(?p:a(?{ $m = ${^MATCH} }))/, '(?{})');
+    is($m, 'a', '(?{}) ^MATCH');
+}