make qr/(?{ __SUB__ })/ safe
authorDavid Mitchell <davem@iabyn.com>
Wed, 24 Apr 2013 15:29:42 +0000 (16:29 +0100)
committerDavid Mitchell <davem@iabyn.com>
Wed, 24 Apr 2013 15:40:15 +0000 (16:40 +0100)
(See RT #113928)

Formerly, __SUB__ within a code block within a qr// returned
a pointer to the "hidden" anon CV that implements the qr// closure. Since
this was never designed to be called directly, it would SEGV if you tried.

The easiest way to make this safe is to skip any CXt_SUB frames that
are marked as CXp_SUB_RE: i.e. skip any subs that are there just to
execute code blocks. For a qr//, this means that we return the sub which
the pattern match is embedded in.

Also, document the behaviour of __SUB__ within code blocks as being
subject to change. It could be argued for example that in these cases it
should return undef. But with the 5.18.0 release a month or two away, just
make it safe for now, and revisit the semantics later if necessary.

pod/perlfunc.pod
pod/perlsub.pod
pp_ctl.c
t/re/reg_eval_scope.t

index 33d36d9..b566fd5 100644 (file)
@@ -7618,9 +7618,12 @@ X<__SUB__>
 
 =for Pod::Functions +current_sub the current subroutine, or C<undef> if not in a subroutine
 
-A special token that returns the a reference to the current subroutine, or
+A special token that returns a reference to the current subroutine, or
 C<undef> outside of a subroutine.
 
+The behaviour of C<__SUB__> within a regex code block (such as C</(?{...})/>)
+is subject to change.
+
 This token is only available under C<use v5.16> or the "current_sub"
 feature.  See L<feature>.
 
index 87d45d3..027d7be 100644 (file)
@@ -232,6 +232,9 @@ your subroutine's name.
       return($x * __SUB__->( $x - 1 ) );
     };
 
+The behaviour of C<__SUB__> within a regex code block (such as C</(?{...})/>)
+is subject to change.
+
 Subroutines whose names are in all upper case are reserved to the Perl
 core, as are modules whose names are in all lower case.  A subroutine in
 all capitals is a loosely-held convention meaning it will be called
index f08e376..0b8ab98 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3285,6 +3285,8 @@ Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
                    *db_seqp = cx->blk_oldcop->cop_seq;
                    continue;
                }
+                if (cx->cx_type & CXp_SUB_RE)
+                    continue;
            }
            else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
                cv = cx->blk_eval.cv;
index 80eeb8a..7eddf87 100644 (file)
@@ -9,7 +9,7 @@ BEGIN {
     skip_all_if_miniperl("no dynamic loading on miniperl, no re");
 }
 
-plan 45;
+plan 48;
 
 fresh_perl_is <<'CODE', '781745', {}, '(?{}) has its own lexical scope';
  my $x = 7; my $a = 4; my $b = 5;
@@ -345,3 +345,26 @@ pass "undef *_ in a re-eval does not cause a double free";
     is ($c1,'(main::r3:8)', 'callers() r3/r3/c3 part 2');
 
 }
+
+# [perl #113928] caller behaving unexpectedly in re-evals
+#
+# make sure __SUB__ within a code block returns something safe.
+# NB waht it actually returns is subject to change
+
+{
+
+    my $s;
+
+    sub f1 { /(?{ $s = CORE::__SUB__; })/ }
+    f1();
+    is ($s, \&f1, '__SUB__ direct');
+
+    my $r = qr/(?{ $s = CORE::__SUB__; })/;
+    sub f2 { "" =~ $r }
+    f2();
+    is ($s, \&f2, '__SUB__ qr');
+
+    sub f3 { "AB" =~ /A${r}B/ }
+    f3();
+    is ($s, \&f3, '__SUB__ qr multi');
+}