This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
RT-23180 - If we skip matching in pp_match for any reason, pos() must still be updated.
authorMatthew Horsfall (alh) <wolfsage@gmail.com>
Sat, 24 Nov 2012 18:05:49 +0000 (13:05 -0500)
committerFather Chrysostomos <sprout@cpan.org>
Sun, 25 Nov 2012 01:48:26 +0000 (17:48 -0800)
MANIFEST
pp_hot.c
t/re/pos.t [new file with mode: 0644]

index 06d33b8..4d6473d 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -5464,6 +5464,7 @@ t/re/pat_special_cc.t             See if special charclasses (\s \w \d) work the same as (\
 t/re/pat_special_cc_thr.t      See if special charclasses (\s \w \d) work the same as (\s and [\s]) under threads
 t/re/pat.t                     See if esoteric patterns work
 t/re/pat_thr.t                 See if esoteric patterns work in another thread
+t/re/pos.t                     Ensure pos() gets set properly after pre-match failures in pp_match
 t/re/qr-72922.t                        Test for bug #72922
 t/re/qr_gc.t                   See if qr doesn't leak
 t/re/qrstack.t                 See if qr expands the stack properly
index 977e22f..8b4bc94 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1350,6 +1350,9 @@ PP(pp_match)
 
     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
 
+    /* We need to know this incase we fail out early - pos() must be reset */
+    global = dynpm->op_pmflags & PMf_GLOBAL;
+
     /* PMdf_USED is set after a ?? matches once */
     if (
 #ifdef USE_ITHREADS
@@ -1359,11 +1362,7 @@ PP(pp_match)
 #endif
     ) {
         DEBUG_r(PerlIO_printf(Perl_debug_log, "?? already matched once"));
-      failure:
-
-       if (gimme == G_ARRAY)
-           RETURN;
-       RETPUSHNO;
+       goto nope;
     }
 
 
@@ -1378,13 +1377,13 @@ PP(pp_match)
 
     if (RX_MINLEN(rx) > (I32)len) {
         DEBUG_r(PerlIO_printf(Perl_debug_log, "String shorter than min possible regex match\n"));
-       goto failure;
+       goto nope;
     }
 
     truebase = t = s;
 
     /* XXXX What part of this is needed with true \G-support? */
-    if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
+    if (global) {
        RX_OFFS(rx)[0].start = -1;
        if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
            MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
diff --git a/t/re/pos.t b/t/re/pos.t
new file mode 100644 (file)
index 0000000..14cc1fa
--- /dev/null
@@ -0,0 +1,68 @@
+#!./perl
+
+# Make sure pos / resetting pos on failed match works
+
+use strict;
+use warnings;
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    require './test.pl';
+}
+
+plan tests => 8;
+
+##  Early bailout of pp_match because matchlen > stringlen
+
+# With a var
+{
+       my $str = "bird";
+
+       $str =~ /i/g;
+
+       is(pos($str),  2, 'pos correct');
+
+       $str =~ /toolongtomatch/g;
+
+       is(pos($str), undef, 'pos undef after failed match');
+}
+
+# With $_
+{
+       $_ = "bird";
+
+       m/i/g;
+
+       is(pos, 2, 'pos correct');
+
+       m/toolongtomatch/g;
+
+       is(pos, undef, 'pos undef after failed match');
+}
+
+## Early bail out of pp_match because ?? already matched
+
+# With a var
+{
+       my $str = "bird";
+
+       for (1..2) {
+               if ($str =~ m?bird?g) {
+                       is(pos($str),  4, 'pos correct');
+               } else {
+                       is(pos($str), undef, 'pos undef after failed match');
+               }
+       }
+}
+
+# With $_
+{
+       for (1..2) {
+               if (m?\d?g) {
+                       is(pos,  1, 'pos correct');
+               } else {
+                       is(pos, undef, 'pos undef after failed match');
+               }
+       }
+}