Document new versions of Data::Dumper and XS::APItest.

[perl5.git] / toke.c

diff --git a/toke.c b/toke.c
index fa4c9c9..58142ab 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -684,7 +684,13 @@ used by perl internally, so extensions should always pass zero.
 */
 
 /* LEX_START_SAME_FILTER indicates that this is not a new file, so it
-   can share filters with the current parser. */
+   can share filters with the current parser.
+   LEX_START_DONT_CLOSE indicates that the file handle wasn't opened by the
+   caller, hence isn't owned by the parser, so shouldn't be closed on parser
+   destruction. This is used to handle the case of defaulting to reading the
+   script from the standard input because no filename was given on the command
+   line (without getting confused by situation where STDIN has been closed, so
+   the script handle is opened on fd 0)  */
 
 void
 Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
@@ -751,7 +757,8 @@ Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp, U32 flags)
        parser->linestart = SvPVX(parser->linestr);
     parser->bufend = parser->bufptr + SvCUR(parser->linestr);
     parser->last_lop = parser->last_uni = NULL;
-    parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES);
+    parser->lex_flags = flags & (LEX_IGNORE_UTF8_HINTS|LEX_EVALBYTES
+                                |LEX_DONT_CLOSE_RSFP);
 
     parser->in_pod = parser->filtered = 0;
 }
@@ -767,7 +774,7 @@ Perl_parser_free(pTHX_  const yy_parser *parser)
     PL_curcop = parser->saved_curcop;
     SvREFCNT_dec(parser->linestr);
 
-    if (parser->rsfp == PerlIO_stdin())
+    if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
        PerlIO_clearerr(parser->rsfp);
     else if (parser->rsfp && (!parser->old_parser ||
                (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
@@ -1283,7 +1290,7 @@ Perl_lex_next_chunk(pTHX_ U32 flags)
        /* End of real input.  Close filehandle (unless it was STDIN),
         * then add implicit termination.
         */
-       if ((PerlIO*)PL_parser->rsfp == PerlIO_stdin())
+       if (PL_parser->lex_flags & LEX_DONT_CLOSE_RSFP)
            PerlIO_clearerr(PL_parser->rsfp);
        else if (PL_parser->rsfp)
            (void)PerlIO_close(PL_parser->rsfp);
@@ -2922,7 +2929,7 @@ S_scan_const(pTHX_ char *start)
            }
 
            /* string-change backslash escapes */
-           if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
+           if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQF", *s)) {
                --s;
                break;
            }
@@ -3509,7 +3516,8 @@ S_scan_const(pTHX_ char *start)
     *d = '\0';
     SvCUR_set(sv, d - SvPVX_const(sv));
     if (SvCUR(sv) >= SvLEN(sv))
-       Perl_croak(aTHX_ "panic: constant overflowed allocated space");
+       Perl_croak(aTHX_ "panic: constant overflowed allocated space, %"UVuf
+                  " >= %"UVuf, (UV)SvCUR(sv), (UV)SvLEN(sv));
 
     SvPOK_on(sv);
     if (PL_encoding && !has_utf8) {
@@ -4476,7 +4484,9 @@ Perl_yylex(pTHX)
     case LEX_INTERPCASEMOD:
 #ifdef DEBUGGING
        if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
-           Perl_croak(aTHX_ "panic: INTERPCASEMOD");
+           Perl_croak(aTHX_
+                      "panic: INTERPCASEMOD bufptr=%p, bufend=%p, *bufptr=%u",
+                      PL_bufptr, PL_bufend, *PL_bufptr);
 #endif
        /* handle \E or end of string */
                if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
@@ -4486,7 +4496,8 @@ Perl_yylex(pTHX)
                PL_lex_casestack[PL_lex_casemods] = '\0';
 
                if (PL_bufptr != PL_bufend
-                   && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
+                   && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q'
+                        || oldmod == 'F')) {
                    PL_bufptr += 2;
                    PL_lex_state = LEX_INTERPCONCAT;
 #ifdef PERL_MAD
@@ -4536,8 +4547,10 @@ Perl_yylex(pTHX)
                if (!PL_madskills) /* when just compiling don't need correct */
                    if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
                        tmp = *s, *s = s[2], s[2] = (char)tmp;  /* misordered... */
-               if ((*s == 'L' || *s == 'U') &&
-                   (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
+               if ((*s == 'L' || *s == 'U' || *s == 'F') &&
+                   (strchr(PL_lex_casestack, 'L')
+                        || strchr(PL_lex_casestack, 'U')
+                        || strchr(PL_lex_casestack, 'F'))) {
                    PL_lex_casestack[--PL_lex_casemods] = '\0';
                    PL_lex_allbrackets--;
                    return REPORT(')');
@@ -4561,8 +4574,10 @@ Perl_yylex(pTHX)
                    NEXTVAL_NEXTTOKE.ival = OP_UC;
                else if (*s == 'Q')
                    NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
+                else if (*s == 'F')
+                   NEXTVAL_NEXTTOKE.ival = OP_FC;
                else
-                   Perl_croak(aTHX_ "panic: yylex");
+                   Perl_croak(aTHX_ "panic: yylex, *s=%u", *s);
                if (PL_madskills) {
                    SV* const tmpsv = newSVpvs("\\ ");
                    /* replace the space with the character we want to escape
@@ -4669,7 +4684,8 @@ Perl_yylex(pTHX)
     case LEX_INTERPCONCAT:
 #ifdef DEBUGGING
        if (PL_lex_brackets)
-           Perl_croak(aTHX_ "panic: INTERPCONCAT");
+           Perl_croak(aTHX_ "panic: INTERPCONCAT, lex_brackets=%ld",
+                      (long) PL_lex_brackets);
 #endif
        if (PL_bufptr == PL_bufend)
            return REPORT(sublex_done());
@@ -5156,7 +5172,8 @@ Perl_yylex(pTHX)
                if (d < PL_bufend)
                    d++;
                else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
-                 Perl_croak(aTHX_ "panic: input overflow");
+                   Perl_croak(aTHX_ "panic: input overflow, %p > %p",
+                              d, PL_bufend);
 #ifdef PERL_MAD
                if (PL_madskills)
                    PL_thiswhite = newSVpvn(s, d - s);
@@ -7409,6 +7426,9 @@ Perl_yylex(pTHX)
        case KEY_fork:
            FUN0(OP_FORK);
 
+       case KEY_fc:
+           UNI(OP_FC);
+
        case KEY_fcntl:
            LOP(OP_FCNTL,XTERM);
 
@@ -8145,7 +8165,7 @@ Perl_yylex(pTHX)
                                }
                                else {
                                    if ( underscore ) {
-                                       if ( *p != ';' )
+                                       if ( !strchr(";@%", *p) )
                                            bad_proto = TRUE;
                                        underscore = FALSE;
                                    }
@@ -9259,7 +9279,6 @@ S_scan_trans(pTHX_ char *start)
     dVAR;
     register char* s;
     OP *o;
-    short *tbl;
     U8 squash;
     U8 del;
     U8 complement;
@@ -9327,8 +9346,7 @@ S_scan_trans(pTHX_ char *start)
     }
   no_more:
 
-    tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
-    o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)tbl);
+    o = newPVOP(nondestruct ? OP_TRANSR : OP_TRANS, 0, (char*)NULL);
     o->op_private &= ~OPpTRANS_ALL;
     o->op_private |= del|squash|complement|
       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
@@ -9865,7 +9883,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
        termlen = 1;
     }
     else {
-       termcode = utf8_to_uvchr((U8*)s, &termlen);
+       termcode = utf8_to_uvchr_buf((U8*)s, (U8*)PL_bufend, &termlen);
        Copy(s, termstr, termlen, U8);
        if (!UTF8_IS_INVARIANT(term))
            has_utf8 = TRUE;
@@ -10180,7 +10198,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
 
     switch (*s) {
     default:
-      Perl_croak(aTHX_ "panic: scan_num");
+       Perl_croak(aTHX_ "panic: scan_num, *s=%d", *s);
 
     /* if it starts with a 0, it could be an octal number, a decimal in
        0.13 disguise, or a hexadecimal number, or a binary number. */