Don’t crash with formats in special blocks

Commit 421f30ed1e9 didn’t go far enough.  If a special block happens
to replace a stub, then a format trying to close over variables in the
special block will be pointing to the wrong outer sub.

Such stubs shouldn’t usually happen, but perl shouldn’t crash.

diff --git a/perly.act b/perly.act
index ce830e3..6516b02 100644 (file)
--- a/perly.act
+++ b/perly.act
@@ -214,7 +214,7 @@ case 2:
                          newFORM((ps[(2) - (4)].val.ival), (ps[(3) - (4)].val.opval), (ps[(4) - (4)].val.opval));
                          (yyval.opval) = (OP*)NULL;
 #endif
-                         if (CvOUTSIDE(fmtcv) && !CvUNIQUE(CvOUTSIDE(fmtcv))) {
+                         if (CvOUTSIDE(fmtcv) && !CvEVAL(CvOUTSIDE(fmtcv))) {
                              SvREFCNT_inc_simple_void(fmtcv);
                              pad_add_anon(fmtcv, OP_NULL);
                          }
@@ -1717,10 +1717,13 @@ case 2:
     { (yyval.opval) = (ps[(1) - (1)].val.opval); ;}
     break;
 
+
+/* Line 1267 of yacc.c.  */
+
       default: break;
     
 
 /* Generated from:
- * 27cce68ad4844f1b8053bfc11206fb9f559e08be6cefd4a986aaa606c0e5fb38 perly.y
+ * efdb10e4176c622005697eec1ff496d913ef986c5297086baa5088bbd3aedaf2 perly.y
  * 38f866dcd8341ad3c0810347587113eb2c6ac7d4f33bdab75b020efce92865be regen_perly.pl
  * ex: set ro: */

diff --git a/perly.h b/perly.h
index d185ee9..8925a2e 100644 (file)
--- a/perly.h
+++ b/perly.h
@@ -5,25 +5,27 @@
  */
 
 #ifdef PERL_CORE
-/* A Bison parser, made by GNU Bison 2.4.3.  */
+/* A Bison parser, made by GNU Bison 2.3.  */
 
 /* Skeleton interface for Bison's Yacc-like parsers in C
-   
-      Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006,
-   2009, 2010 Free Software Foundation, Inc.
-   
-   This program is free software: you can redistribute it and/or modify
+
+   Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006
+   Free Software Foundation, Inc.
+
+   This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
-   the Free Software Foundation, either version 3 of the License, or
-   (at your option) any later version.
-   
+   the Free Software Foundation; either version 2, or (at your option)
+   any later version.
+
    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.
-   
+
    You should have received a copy of the GNU General Public License
-   along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
+   along with this program; if not, write to the Free Software
+   Foundation, Inc., 51 Franklin Street, Fifth Floor,
+   Boston, MA 02110-1301, USA.  */
 
 /* As a special exception, you may create a larger work that contains
    part or all of the Bison parser skeleton and distribute that work
@@ -34,11 +36,10 @@
    special exception, which will cause the skeleton and the resulting
    Bison output files to be licensed under the GNU General Public
    License without this special exception.
-   
+
    This special exception was added by the Free Software Foundation in
    version 2.2 of Bison.  */
 
-
 /* Tokens.  */
 #ifndef YYTOKENTYPE
 # define YYTOKENTYPE
@@ -126,7 +127,6 @@
      PEG = 336
    };
 #endif
-
 /* Tokens.  */
 #define GRAMPROG 258
 #define GRAMEXPR 259
@@ -210,13 +210,11 @@
 
 
 
+
 #endif /* PERL_CORE */
 #if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED
 typedef union YYSTYPE
 {
-
-/* Line 1685 of yacc.c  */
-
     I32        ival; /* __DEFAULT__ (marker for regen_perly.pl;
                                must always be 1st union member) */
     char *pval;
@@ -232,21 +230,18 @@ typedef union YYSTYPE
 #ifdef PERL_MAD
     TOKEN* tkval;
 #endif
-
-
-
-/* Line 1685 of yacc.c  */
-} YYSTYPE;
-# define YYSTYPE_IS_TRIVIAL 1
+}
+/* Line 1529 of yacc.c.  */
+       YYSTYPE;
 # define yystype YYSTYPE /* obsolescent; will be withdrawn */
 # define YYSTYPE_IS_DECLARED 1
+# define YYSTYPE_IS_TRIVIAL 1
 #endif
 
 
 
 
-
 /* Generated from:
- * 27cce68ad4844f1b8053bfc11206fb9f559e08be6cefd4a986aaa606c0e5fb38 perly.y
+ * efdb10e4176c622005697eec1ff496d913ef986c5297086baa5088bbd3aedaf2 perly.y
  * 38f866dcd8341ad3c0810347587113eb2c6ac7d4f33bdab75b020efce92865be regen_perly.pl
  * ex: set ro: */

diff --git a/perly.tab b/perly.tab
index 86cc024..309d5d9 100644 (file)
--- a/perly.tab
+++ b/perly.tab
@@ -223,9 +223,9 @@ static const char *const yytname[] =
   "':'", "DORDOR", "OROR", "ANDAND", "BITOROP", "BITANDOP", "SHIFTOP",
   "MATCHOP", "'!'", "'~'", "REFGEN", "UMINUS", "POWOP", "POSTDEC",
   "POSTINC", "PREDEC", "PREINC", "ARROW", "')'", "'('", "PEG", "$accept",
-  "grammar", "$@1", "$@2", "$@3", "$@4", "$@5", "$@6", "block", "remember",
+  "grammar", "@1", "@2", "@3", "@4", "@5", "@6", "block", "remember",
   "mydefsv", "mblock", "mremember", "stmtseq", "fullstmt", "labfullstmt",
-  "barestmt", "$@7", "$@8", "sideff", "else", "cont", "mintro", "nexpr",
+  "barestmt", "@7", "@8", "sideff", "else", "cont", "mintro", "nexpr",
   "texpr", "iexpr", "mexpr", "mnexpr", "miexpr", "formname", "startsub",
   "startanonsub", "startformsub", "subname", "proto", "subattrlist",
   "myattrlist", "subbody", "expr", "listexpr", "listop", "@9", "method",
@@ -1089,6 +1089,6 @@ static const toketypes yy_type_tab[] =
 };
 
 /* Generated from:
- * 27cce68ad4844f1b8053bfc11206fb9f559e08be6cefd4a986aaa606c0e5fb38 perly.y
+ * efdb10e4176c622005697eec1ff496d913ef986c5297086baa5088bbd3aedaf2 perly.y
  * 38f866dcd8341ad3c0810347587113eb2c6ac7d4f33bdab75b020efce92865be regen_perly.pl
  * ex: set ro: */

diff --git a/perly.y b/perly.y
index e103db4..c819b5b 100644 (file)
--- a/perly.y
+++ b/perly.y
@@ -292,7 +292,7 @@ barestmt:   PLUGSTMT
                          newFORM($2, $3, $4);
                          $$ = (OP*)NULL;
 #endif
-                         if (CvOUTSIDE(fmtcv) && !CvUNIQUE(CvOUTSIDE(fmtcv))) {
+                         if (CvOUTSIDE(fmtcv) && !CvEVAL(CvOUTSIDE(fmtcv))) {
                              SvREFCNT_inc_simple_void(fmtcv);
                              pad_add_anon(fmtcv, OP_NULL);
                          }

diff --git a/t/comp/form_scope.t b/t/comp/form_scope.t
index d805ffa..6344652 100644 (file)
--- a/t/comp/form_scope.t
+++ b/t/comp/form_scope.t
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..7\n";
+print "1..8\n";
 
 # Tests bug #22977.  Test case from Dave Mitchell.
 sub f ($);
@@ -97,3 +97,17 @@ $next = $clo1;
 &$clo2(0);
 $next = $clo2;
 &$clo1(0);
+
+# This is a variation of bug #22977, which crashes or fails an assertion
+# up to 5.16.
+# Keep this test last if you want test numbers to be sane.
+BEGIN { \&END }
+END {
+  my $test = "ok 8";
+  *STDOUT = *STDOUT5{FORMAT};
+  write;
+  format STDOUT5 =
+@<<<<<<<
+$test
+.
+}