This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix for perl #112316: Wrong behavior regarding labels with same prefix
authorBrian Fraser <fraserbn@gmail.com>
Fri, 6 Apr 2012 20:47:14 +0000 (17:47 -0300)
committerFather Chrysostomos <sprout@cpan.org>
Sat, 7 Apr 2012 05:00:14 +0000 (22:00 -0700)
The code that compared non UTF-8 labels neglected to check that
the label's length was equal before comparing them with a memEQ,
which lead to code that used labels with the same prefixes to fail:

./perl -Ilib -E 'CATCH: { CATCHLOOP: { last CATCH;  } die  }'

pp_ctl.c
t/op/goto.t
t/op/loopctl.t

index 80aa419..8f4c103 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1424,8 +1424,8 @@ S_dopoptolabel(pTHX_ const char *label, STRLEN len, U32 flags)
                             : (bytes_cmp_utf8(
                                         (const U8*)label, len,
                                         (const U8*)cx_label, cx_label_len) == 0)
-                    : ((cx_label == label)
-                                    || memEQ(cx_label, label, len))) ) {
+                    : (len == cx_label_len && ((cx_label == label)
+                                    || memEQ(cx_label, label, len))) )) {
                DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
                        (long)i, cx_label));
                continue;
@@ -2806,8 +2806,8 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac
                             : (bytes_cmp_utf8(
                                         (const U8*)label, len,
                                         (const U8*)kid_label, kid_label_len) == 0)
-                    : ((kid_label == label)
-                                    || memEQ(kid_label, label, len))))
+                    : ( len == kid_label_len && ((kid_label == label)
+                                    || memEQ(kid_label, label, len)))))
                    return kid;
            }
        }
index ad83c29..cb9c6b6 100644 (file)
@@ -10,7 +10,7 @@ BEGIN {
 
 use warnings;
 use strict;
-plan tests => 79;
+plan tests => 80;
 our $TODO;
 
 my $deprecated = 0;
@@ -611,3 +611,28 @@ alef: bet: gimel:
 $foo .= ",1.";
 $foo .= ",2.";
 is($foo, ",0.,1.,2.", "third of three stacked labels");
+
+# [perl #112316] Wrong behavior regarding labels with same prefix
+sub same_prefix_labels {
+    my $pass;
+    my $first_time = 1;
+    CATCH: {
+        if ( $first_time ) {
+            CATCHLOOP: {
+                if ( !$first_time ) {
+                  return 0;
+                }
+                $first_time--;
+                goto CATCH;
+            }
+        }
+        else {
+            return 1;
+        }
+    }
+}
+
+ok(
+   same_prefix_labels(),
+   "perl 112316: goto and labels with the same prefix doesn't get mixed up"
+);
index 6b4e5c6..3a8fc9a 100644 (file)
@@ -36,7 +36,7 @@ BEGIN {
 }
 
 require "test.pl";
-plan( tests => 54 );
+plan( tests => 55 );
 
 my $ok;
 
@@ -994,3 +994,15 @@ cmp_ok($ok,'==',1,'dynamically scoped');
     }
     is($x_21469, 'X', "bug 21469: X okay at end of loop");
 }
+
+# [perl #112316] Wrong behavior regarding labels with same prefix
+{
+    my $fail;
+    CATCH: {
+    CATCHLOOP: {
+            last CATCH;
+        }
+        $fail = 1;
+    }
+    ok(!$fail, "perl 112316: Labels with the same prefix don't get mixed up.");
+}