return FALSE;
memcpy(&he_name[8], name, namelen);
- return
- cop_hints_fetch_pvn(
- PL_curcop, he_name, 8 + namelen, 0,
- REFCOUNTED_HE_EXISTS
- );
+ return cBOOL(cop_hints_fetch_pvn(PL_curcop, he_name, 8 + namelen, 0,
+ REFCOUNTED_HE_EXISTS));
}
/*
*/
/* 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)
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;
}
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)))
/* 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);
}
/* 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;
}
*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) {
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') {
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
PL_lex_allbrackets--;
return REPORT(')');
}
+ else if ( PL_bufptr != PL_bufend && PL_bufptr[1] == 'E' ) {
+ /* Got an unpaired \E */
+ Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
+ "Useless use of \\E");
+ }
#ifdef PERL_MAD
while (PL_bufptr != PL_bufend &&
PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
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(')');
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
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());
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);
if (*t == '}' || *t == ']') {
t++;
PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
+ /* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Scalar value %.*s better written as $%.*s",
(int)(t-PL_bufptr), PL_bufptr,
case KEY_fork:
FUN0(OP_FORK);
+ case KEY_fc:
+ UNI(OP_FC);
+
case KEY_fcntl:
LOP(OP_FCNTL,XTERM);
if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
/* [perl #16184] */
&& !(t[0] == '=' && t[1] == '>')
+ && !(t[0] == ':' && t[1] == ':')
&& !keyword(s, d-s, 0)
) {
int parms_len = (int)(d-s);
case KEY_sort:
checkcomma(s,PL_tokenbuf,"subroutine name");
s = SKIPSPACE1(s);
- if (*s == ';' || *s == ')') /* probably a close */
- Perl_croak(aTHX_ "sort is now a reserved word");
PL_expect = XTERM;
s = force_word(s,WORD,TRUE,TRUE,FALSE);
LOP(OP_SORT,XREF);
}
else {
if ( underscore ) {
- if ( *p != ';' )
+ if ( !strchr(";@%", *p) )
bad_proto = TRUE;
underscore = FALSE;
}
dVAR;
register char* s;
OP *o;
- short *tbl;
U8 squash;
U8 del;
U8 complement;
}
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)|
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;
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. */
if (s[1] == 0xFE) {
/* UTF-16 little-endian? (or UTF-32LE?) */
if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */
+ /* diag_listed_as: Unsupported script encoding %s */
Perl_croak(aTHX_ "Unsupported script encoding UTF-32LE");
#ifndef PERL_NO_UTF16_FILTER
if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (BOM)\n");
s = add_utf16_textfilter(s, TRUE);
}
#else
+ /* diag_listed_as: Unsupported script encoding %s */
Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
#endif
}
s = add_utf16_textfilter(s, FALSE);
}
#else
+ /* diag_listed_as: Unsupported script encoding %s */
Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
#endif
}
if (s[1] == 0) {
if (s[2] == 0xFE && s[3] == 0xFF) {
/* UTF-32 big-endian */
+ /* diag_listed_as: Unsupported script encoding %s */
Perl_croak(aTHX_ "Unsupported script encoding UTF-32BE");
}
}
if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
s = add_utf16_textfilter(s, FALSE);
#else
+ /* diag_listed_as: Unsupported script encoding %s */
Perl_croak(aTHX_ "Unsupported script encoding UTF-16BE");
#endif
}
if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
s = add_utf16_textfilter(s, TRUE);
#else
+ /* diag_listed_as: Unsupported script encoding %s */
Perl_croak(aTHX_ "Unsupported script encoding UTF-16LE");
#endif
}
rev += (*end - '0') * mult;
mult *= 10;
if (orev > rev)
+ /* diag_listed_as: Integer overflow in %s number */
Perl_ck_warner_d(aTHX_ packWARN(WARN_OVERFLOW),
"Integer overflow in decimal number");
}
https://perl5.git.perl.org / perl5.git / blobdiff