This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Nested formats
authorFather Chrysostomos <sprout@cpan.org>
Mon, 6 Aug 2012 16:48:07 +0000 (09:48 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Mon, 6 Aug 2012 21:04:03 +0000 (14:04 -0700)
Are nested formats a good idea?  Probably not.  But the only rea-
son they don’t work is that the parser becomes confused and loses
track of where it is.

And it would be nice to have some consistency.  I can put sub defini-
tions inside a format:

format =
@
;sub foo {
    bar
}
.

and:

format =
@
{
    sub foo {
        bar
    }
}
.

so why not these?

format foo =
@
;format bar =
@
.
.

format foo =
@
{
    format bar =
@
.
}
.

In perl 5.17.2 and earlier, you can nest formats, but, due to the
parser being confused, the outer format must be terminated with }
instead of a dot.  That stopped working with commit 7c70caa5333.

format =
@<<<<<<<<<<<<<<<
"Just another"; format STDERR =
@<<<<<<<<<<<<<<<
"Perl hacker"
.
}
write; select STDERR;
write;

t/op/write.t
toke.c

index 17b8869..2d5b0ac 100644 (file)
@@ -61,7 +61,7 @@ for my $tref ( @NumTests ){
 my $bas_tests = 20;
 
 # number of tests in section 3
-my $bug_tests = 8 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3 + 96 + 4;
+my $bug_tests = 8 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3 + 96 + 5;
 
 # number of tests in section 4
 my $hmb_tests = 35;
@@ -1017,6 +1017,24 @@ format =
 ;1
 |, 'format = ... } is not allowed';
 
+open(NEST, '>Op_write.tmp') || die "Can't create Op_write.tmp";
+format NEST =
+@<<<
+{
+    my $birds = "birds";
+    local *NEST = *BIRDS{FORMAT};
+    write NEST;
+    format BIRDS =
+@<<<<<
+$birds;
+.
+    "nest"
+}
+.
+write NEST;
+close NEST or die "Could not close: $!";
+is cat('Op_write.tmp'), "birds\nnest\n", 'nested formats';
+
 
 #############################
 ## Section 4
diff --git a/toke.c b/toke.c
index 02b6b86..f04dfd1 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -6015,7 +6015,7 @@ Perl_yylex(pTHX)
                    goto retry;
                }
        }
-       if (PL_lex_brackets < PL_lex_formbrack) {
+       if (PL_expect == XBLOCK) {
            const char *t = s;
 #ifdef PERL_STRICT_CR
            while (SPACE_OR_TAB(*t))
@@ -6028,7 +6028,9 @@ Perl_yylex(pTHX)
                formbrack = TRUE;
                ENTER;
                SAVEI8(PL_parser->form_lex_state);
+               SAVEI32(PL_lex_formbrack);
                PL_parser->form_lex_state = PL_lex_state;
+               PL_lex_formbrack = PL_lex_brackets + 1;
                goto leftbracket;
            }
        }
@@ -6387,7 +6389,6 @@ Perl_yylex(pTHX)
 #endif
            && (s == PL_linestart || s[-1] == '\n') )
        {
-           PL_lex_formbrack = 0;
            PL_expect = XSTATE;
            formbrack = TRUE;
            goto rightbracket;
@@ -8205,7 +8206,6 @@ Perl_yylex(pTHX)
                }
 
                if (key == KEY_format) {
-                   PL_lex_formbrack = PL_lex_brackets + 1;
 #ifdef PERL_MAD
                    PL_thistoken = subtoken;
                    s = d;
@@ -8214,7 +8214,7 @@ Perl_yylex(pTHX)
                        (void) force_word(PL_oldbufptr + tboffset, WORD,
                                          FALSE, TRUE, TRUE);
 #endif
-                   OPERATOR(FORMAT);
+                   PREBLOCK(FORMAT);
                }
 
                /* Look for a prototype */