/* toke.c
*
- * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
+ * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
*/
/*
- * "It all comes from here, the stench and the peril." --Frodo
+ * 'It all comes from here, the stench and the peril.' --Frodo
+ *
+ * [p.719 of _The Lord of the Rings_, IV/ix: "Shelob's Lair"]
*/
/*
#define new_constant(a,b,c,d,e,f,g) \
S_new_constant(aTHX_ a,b,STR_WITH_LEN(c),d,e,f, g)
-#define yylval (PL_parser->yylval)
+#define pl_yylval (PL_parser->yylval)
/* YYINITDEPTH -- initial size of the parser's stacks. */
#define YYINITDEPTH 200
*/
#ifdef DEBUGGING /* Serve -DT. */
-# define REPORT(retval) tokereport((I32)retval)
+# define REPORT(retval) tokereport((I32)retval, &pl_yylval)
#else
# define REPORT(retval) (retval)
#endif
#define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
#define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
#define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
-#define LOOPX(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
-#define FTST(f) return (yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
-#define FUN0(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
-#define FUN1(f) return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
-#define BOop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
-#define BAop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
-#define SHop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
-#define PWop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
-#define PMop(f) return(yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
-#define Aop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
-#define Mop(f) return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
-#define Eop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
-#define Rop(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
+#define LOOPX(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
+#define FTST(f) return (pl_yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
+#define FUN0(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
+#define FUN1(f) return (pl_yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
+#define BOop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
+#define BAop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
+#define SHop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
+#define PWop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
+#define PMop(f) return(pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
+#define Aop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
+#define Mop(f) return ao((pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
+#define Eop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
+#define Rop(f) return (pl_yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
/* This bit of chicanery makes a unary function followed by
* a parenthesis into a function with one argument, highest precedence.
* operator (such as C<shift // 0>).
*/
#define UNI2(f,x) { \
- yylval.ival = f; \
+ pl_yylval.ival = f; \
PL_expect = x; \
PL_bufptr = s; \
PL_last_uni = PL_oldbufptr; \
#define UNIDOR(f) UNI2(f,XTERMORDORDOR)
#define UNIBRACK(f) { \
- yylval.ival = f; \
+ pl_yylval.ival = f; \
PL_bufptr = s; \
PL_last_uni = PL_oldbufptr; \
if (*s == '(') \
}
/* grandfather return to old style */
-#define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
+#define OLDLOP(f) return(pl_yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
#ifdef DEBUGGING
-/* how to interpret the yylval associated with the token */
+/* how to interpret the pl_yylval associated with the token */
enum token_type {
TOKENTYPE_NONE,
TOKENTYPE_IVAL,
- TOKENTYPE_OPNUM, /* yylval.ival contains an opcode number */
+ TOKENTYPE_OPNUM, /* pl_yylval.ival contains an opcode number */
TOKENTYPE_PVAL,
TOKENTYPE_OPVAL,
TOKENTYPE_GVVAL
{ WHEN, TOKENTYPE_IVAL, "WHEN" },
{ WHILE, TOKENTYPE_IVAL, "WHILE" },
{ WORD, TOKENTYPE_OPVAL, "WORD" },
+ { YADAYADA, TOKENTYPE_IVAL, "YADAYADA" },
{ 0, TOKENTYPE_NONE, NULL }
};
-/* dump the returned token in rv, plus any optional arg in yylval */
+/* dump the returned token in rv, plus any optional arg in pl_yylval */
STATIC int
-S_tokereport(pTHX_ I32 rv)
+S_tokereport(pTHX_ I32 rv, const YYSTYPE* lvalp)
{
dVAR;
+
+ PERL_ARGS_ASSERT_TOKEREPORT;
+
if (DEBUG_T_TEST) {
const char *name = NULL;
enum token_type type = TOKENTYPE_NONE;
case TOKENTYPE_GVVAL: /* doesn't appear to be used */
break;
case TOKENTYPE_IVAL:
- Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)yylval.ival);
+ Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)lvalp->ival);
break;
case TOKENTYPE_OPNUM:
Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
- PL_op_name[yylval.ival]);
+ PL_op_name[lvalp->ival]);
break;
case TOKENTYPE_PVAL:
- Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval);
+ Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
break;
case TOKENTYPE_OPVAL:
- if (yylval.opval) {
+ if (lvalp->opval) {
Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
- PL_op_name[yylval.opval->op_type]);
- if (yylval.opval->op_type == OP_CONST) {
+ PL_op_name[lvalp->opval->op_type]);
+ if (lvalp->opval->op_type == OP_CONST) {
Perl_sv_catpvf(aTHX_ report, " %s",
- SvPEEK(cSVOPx_sv(yylval.opval)));
+ SvPEEK(cSVOPx_sv(lvalp->opval)));
}
}
/* print the buffer with suitable escapes */
STATIC void
-S_printbuf(pTHX_ const char* fmt, const char* s)
+S_printbuf(pTHX_ const char *const fmt, const char *const s)
{
SV* const tmp = newSVpvs("");
+
+ PERL_ARGS_ASSERT_PRINTBUF;
+
PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
SvREFCNT_dec(tmp);
}
if (*PL_bufptr == '=') {
PL_bufptr++;
if (toketype == ANDAND)
- yylval.ival = OP_ANDASSIGN;
+ pl_yylval.ival = OP_ANDASSIGN;
else if (toketype == OROR)
- yylval.ival = OP_ORASSIGN;
+ pl_yylval.ival = OP_ORASSIGN;
else if (toketype == DORDOR)
- yylval.ival = OP_DORASSIGN;
+ pl_yylval.ival = OP_DORASSIGN;
toketype = ASSIGNOP;
}
return toketype;
*/
STATIC void
-S_no_op(pTHX_ const char *what, char *s)
+S_no_op(pTHX_ const char *const what, char *s)
{
dVAR;
char * const oldbp = PL_bufptr;
const bool is_first = (PL_oldbufptr == PL_linestart);
+ PERL_ARGS_ASSERT_NO_OP;
+
if (!s)
s = oldbp;
else
if (nl)
*nl = '\0';
}
- else if (
-#ifdef EBCDIC
- iscntrl(PL_multi_close)
-#else
- PL_multi_close < 32 || PL_multi_close == 127
-#endif
- ) {
+ else if (isCNTRL(PL_multi_close)) {
*tmpbuf = '^';
tmpbuf[1] = (char)toCTRL(PL_multi_close);
tmpbuf[2] = '\0';
#define FEATURE_IS_ENABLED(name) \
((0 != (PL_hints & HINT_LOCALIZE_HH)) \
&& S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
+/* The longest string we pass in. */
+#define MAX_FEATURE_LEN (sizeof("switch")-1)
+
/*
* S_feature_is_enabled
* Check whether the named feature is enabled.
*/
STATIC bool
-S_feature_is_enabled(pTHX_ const char *name, STRLEN namelen)
+S_feature_is_enabled(pTHX_ const char *const name, STRLEN namelen)
{
dVAR;
HV * const hinthv = GvHV(PL_hintgv);
- char he_name[32] = "feature_";
- (void) my_strlcpy(&he_name[8], name, 24);
+ char he_name[8 + MAX_FEATURE_LEN] = "feature_";
+
+ PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
+
+ assert(namelen <= MAX_FEATURE_LEN);
+ memcpy(&he_name[8], name, namelen);
return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
}
*/
void
-Perl_deprecate(pTHX_ const char *s)
+Perl_deprecate(pTHX_ const char *const s)
{
+ PERL_ARGS_ASSERT_DEPRECATE;
+
if (ckWARN(WARN_DEPRECATED))
Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
}
void
-Perl_deprecate_old(pTHX_ const char *s)
+Perl_deprecate_old(pTHX_ const char *const s)
{
/* This function should NOT be called for any new deprecated warnings */
/* Use Perl_deprecate instead */
/* live under the "syntax" category. It is now a top-level category */
/* in its own right. */
+ PERL_ARGS_ASSERT_DEPRECATE_OLD;
+
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Use of %s is deprecated", s);
{
register const char *s = SvPVX_const(sv);
register const char * const e = s + SvCUR(sv);
+
+ PERL_ARGS_ASSERT_STRIP_RETURN;
+
/* outer loop optimized to do nothing if there are no CR-LFs */
while (s < e) {
if (*s++ == '\r' && *s == '\n') {
#else
parser->nexttoke = 0;
#endif
+ parser->error_count = oparser ? oparser->error_count : 0;
parser->copline = NOLINE;
parser->lex_state = LEX_NORMAL;
parser->expect = XSTATE;
parser->rsfp = rsfp;
parser->rsfp_filters = (new_filter || !oparser) ? newAV()
- : (AV*)SvREFCNT_inc(oparser->rsfp_filters);
+ : MUTABLE_AV(SvREFCNT_inc(oparser->rsfp_filters));
Newx(parser->lex_brackstack, 120, char);
Newx(parser->lex_casestack, 12, char);
void
Perl_parser_free(pTHX_ const yy_parser *parser)
{
+ PERL_ARGS_ASSERT_PARSER_FREE;
+
PL_curcop = parser->saved_curcop;
SvREFCNT_dec(parser->linestr);
if (parser->rsfp == PerlIO_stdin())
PerlIO_clearerr(parser->rsfp);
- else if (parser->rsfp && parser->old_parser
- && parser->rsfp != parser->old_parser->rsfp)
+ else if (parser->rsfp && (!parser->old_parser ||
+ (parser->old_parser && parser->rsfp != parser->old_parser->rsfp)))
PerlIO_close(parser->rsfp);
SvREFCNT_dec(parser->rsfp_filters);
const char *n;
const char *e;
+ PERL_ARGS_ASSERT_INCLINE;
+
CopLINE_inc(PL_curcop);
if (*s++ != '#')
return;
if (t - s > 0) {
const STRLEN len = t - s;
#ifndef USE_ITHREADS
- const char * const cf = CopFILE(PL_curcop);
- STRLEN tmplen = cf ? strlen(cf) : 0;
+ SV *const temp_sv = CopFILESV(PL_curcop);
+ const char *cf;
+ STRLEN tmplen;
+
+ if (temp_sv) {
+ cf = SvPVX(temp_sv);
+ tmplen = SvCUR(temp_sv);
+ } else {
+ cf = NULL;
+ tmplen = 0;
+ }
+
if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
/* must copy *{"::_<(eval N)[oldfilename:L]"}
* to *{"::_<newfilename"} */
gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
/* adjust ${"::_<newfilename"} to store the new file name */
GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
- GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
- GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
+ GvHV(gv2) = MUTABLE_HV(SvREFCNT_inc(GvHV(*gvp)));
+ GvAV(gv2) = MUTABLE_AV(SvREFCNT_inc(GvAV(*gvp)));
}
if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
STATIC char *
S_skipspace0(pTHX_ register char *s)
{
+ PERL_ARGS_ASSERT_SKIPSPACE0;
+
s = skipspace(s);
if (!PL_madskills)
return s;
const char *start = s;
I32 startoff = start - SvPVX(PL_linestr);
+ PERL_ARGS_ASSERT_SKIPSPACE1;
+
s = skipspace(s);
if (!PL_madskills)
return s;
const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
const I32 startoff = s - SvPVX(PL_linestr);
+ PERL_ARGS_ASSERT_SKIPSPACE2;
+
s = skipspace(s);
PL_bufptr = SvPVX(PL_linestr) + bufptroff;
if (!PL_madskills || !svp)
#endif
STATIC void
-S_update_debugger_info(pTHX_ SV *orig_sv, const char *buf, STRLEN len)
+S_update_debugger_info(pTHX_ SV *orig_sv, const char *const buf, STRLEN len)
{
AV *av = CopFILEAVx(PL_curcop);
if (av) {
int curoff;
int startoff = s - SvPVX(PL_linestr);
+ PERL_ARGS_ASSERT_SKIPSPACE;
+
if (PL_skipwhite) {
sv_free(PL_skipwhite);
PL_skipwhite = 0;
}
#endif
+ PERL_ARGS_ASSERT_SKIPSPACE;
if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
while (s < PL_bufend && SPACE_OR_TAB(*s))
}
else if (PL_minus_n) {
#ifdef PERL_MAD
- sv_catpvn(PL_linestr, ";}", 2);
+ sv_catpvs(PL_linestr, ";}");
#else
- sv_setpvn(PL_linestr, ";}", 2);
+ sv_setpvs(PL_linestr, ";}");
#endif
PL_minus_n = 0;
}
else
#ifdef PERL_MAD
- sv_catpvn(PL_linestr,";", 1);
+ sv_catpvs(PL_linestr,";");
#else
- sv_setpvn(PL_linestr,";", 1);
+ sv_setpvs(PL_linestr,";");
#endif
/* reset variables for next time we lex */
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
- /* Close the filehandle. Could be from -P preprocessor,
+ /* Close the filehandle. Could be from
* STDIN, or a regular file. If we were reading code from
* STDIN (because the commandline held no -e or filename)
* then we don't close it, we reset it so the code can
* read from STDIN too.
*/
- if (PL_preprocess && !PL_in_eval)
- (void)PerlProc_pclose(PL_rsfp);
- else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
+ if ((PerlIO*)PL_rsfp == PerlIO_stdin())
PerlIO_clearerr(PL_rsfp);
else
(void)PerlIO_close(PL_rsfp);
/* debugger active and we're not compiling the debugger code,
* so store the line into the debugger's array of lines
*/
- if (PERLDB_LINE && PL_curstash != PL_debstash)
+ if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
update_debugger_info(NULL, PL_bufptr, PL_bufend - PL_bufptr);
}
S_lop(pTHX_ I32 f, int x, char *s)
{
dVAR;
- yylval.ival = f;
+
+ PERL_ARGS_ASSERT_LOP;
+
+ pl_yylval.ival = f;
CLINE;
PL_expect = x;
PL_bufptr = s;
where = &PL_nexttoke[PL_curforce].next_mad;
if (PL_faketokens)
- sv_setpvn(sv, "", 0);
+ sv_setpvs(sv, "");
else {
if (!IN_BYTES) {
if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
/* keep a slot open for the head of the list? */
if (slot != '_' && *where && (*where)->mad_key == '^') {
(*where)->mad_key = slot;
- sv_free((SV*)((*where)->mad_val));
+ sv_free(MUTABLE_SV(((*where)->mad_val)));
(*where)->mad_val = (void*)sv;
}
else
S_force_next(pTHX_ I32 type)
{
dVAR;
+#ifdef DEBUGGING
+ if (DEBUG_T_TEST) {
+ PerlIO_printf(Perl_debug_log, "### forced token:\n");
+ tokereport(type, &NEXTVAL_NEXTTOKE);
+ }
+#endif
#ifdef PERL_MAD
if (PL_curforce < 0)
start_force(PL_lasttoke);
}
STATIC SV *
-S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len)
+S_newSV_maybe_utf8(pTHX_ const char *const start, STRLEN len)
{
dVAR;
- SV * const sv = newSVpvn(start,len);
- if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len))
- SvUTF8_on(sv);
+ SV * const sv = newSVpvn_utf8(start, len,
+ UTF && !IN_BYTES
+ && is_utf8_string((const U8*)start, len));
return sv;
}
register char *s;
STRLEN len;
+ PERL_ARGS_ASSERT_FORCE_WORD;
+
start = SKIPSPACE1(start);
s = start;
if (isIDFIRST_lazy_if(s,UTF) ||
S_force_ident(pTHX_ register const char *s, int kind)
{
dVAR;
+
+ PERL_ARGS_ASSERT_FORCE_IDENT;
+
if (*s) {
const STRLEN len = strlen(s);
OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
const char *start = SvPV_const(sv,len);
const char * const end = start + len;
const bool utf = SvUTF8(sv) ? TRUE : FALSE;
+
+ PERL_ARGS_ASSERT_STR_TO_VERSION;
+
while (start < end) {
STRLEN skip;
UV n;
I32 startoff = s - SvPVX(PL_linestr);
#endif
+ PERL_ARGS_ASSERT_FORCE_VERSION;
+
s = SKIPSPACE1(s);
d = s;
#endif
if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
SV *ver;
- s = scan_num(s, &yylval);
- version = yylval.opval;
+ s = scan_num(s, &pl_yylval);
+ version = pl_yylval.opval;
ver = cSVOPx(version)->op_sv;
if (SvPOK(ver) && !SvNIOK(ver)) {
SvUPGRADE(ver, SVt_PVNV);
STRLEN len = 0;
SV *pv = sv;
+ PERL_ARGS_ASSERT_TOKEQ;
+
if (!SvLEN(sv))
goto finish;
goto finish;
d = s;
if ( PL_hints & HINT_NEW_STRING ) {
- pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len));
- if (SvUTF8(sv))
- SvUTF8_on(pv);
+ pv = newSVpvn_flags(SvPVX_const(pv), len, SVs_TEMP | SvUTF8(sv));
}
while (s < send) {
if (*s == '\\') {
/*
* S_sublex_start
- * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
+ * Assumes that pl_yylval.ival is the op we're creating (e.g. OP_LCFIRST).
*
* Pattern matching will set PL_lex_op to the pattern-matching op to
- * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
+ * make (we return THING if pl_yylval.ival is OP_NULL, PMFUNC otherwise).
*
* OP_CONST and OP_READLINE are easy--just make the new op and return.
*
S_sublex_start(pTHX)
{
dVAR;
- register const I32 op_type = yylval.ival;
+ register const I32 op_type = pl_yylval.ival;
if (op_type == OP_NULL) {
- yylval.opval = PL_lex_op;
+ pl_yylval.opval = PL_lex_op;
PL_lex_op = NULL;
return THING;
}
/* Overloaded constants, nothing fancy: Convert to SVt_PV: */
STRLEN len;
const char * const p = SvPV_const(sv, len);
- SV * const nsv = newSVpvn(p, len);
- if (SvUTF8(sv))
- SvUTF8_on(nsv);
+ SV * const nsv = newSVpvn_flags(p, len, SvUTF8(sv));
SvREFCNT_dec(sv);
sv = nsv;
}
- yylval.opval = (OP*)newSVOP(op_type, 0, sv);
+ pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
PL_lex_stuff = NULL;
/* Allow <FH> // "foo" */
if (op_type == OP_READLINE)
else if (op_type == OP_BACKTICK && PL_lex_op) {
/* readpipe() vas overriden */
cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
- yylval.opval = PL_lex_op;
+ pl_yylval.opval = PL_lex_op;
PL_lex_op = NULL;
PL_lex_stuff = NULL;
return THING;
PL_expect = XTERM;
if (PL_lex_op) {
- yylval.opval = PL_lex_op;
+ pl_yylval.opval = PL_lex_op;
PL_lex_op = NULL;
return PMFUNC;
}
if (SvUTF8(PL_linestr))
SvUTF8_on(sv);
PL_expect = XOPERATOR;
- yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
return THING;
}
PL_thiswhite = 0;
}
if (PL_thistoken)
- sv_setpvn(PL_thistoken,"",0);
+ sv_setpvs(PL_thistoken,"");
else
PL_realtokenstart = -1;
}
Returns a pointer to the character scanned up to. If this is
advanced from the start pointer supplied (i.e. if anything was
successfully parsed), will leave an OP for the substring scanned
- in yylval. Caller must intuit reason for not parsing further
+ in pl_yylval. Caller must intuit reason for not parsing further
by looking at the next characters herself.
In patterns:
bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
#endif
+ PERL_ARGS_ASSERT_SCAN_CONST;
+
if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
/* If we are doing a trans and we know we want UTF8 set expectation */
has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
else if (*s == '$') {
if (!PL_lex_inpat) /* not a regexp, so $ must be var */
break;
- if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
+ if (s + 1 < send && !strchr("()| \r\n\t", s[1])) {
+ if (s[1] == '\\' && ckWARN(WARN_AMBIGUOUS)) {
+ Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
+ "Possible unintended interpolation of $\\ in regex");
+ }
break; /* in regexp, $ might be tail anchor */
+ }
}
/* End of else if chain - OP_TRANS rejoin rest */
SvPV_shrink_to_cur(sv);
}
- /* return the substring (via yylval) only if we parsed anything */
+ /* return the substring (via pl_yylval) only if we parsed anything */
if (s > PL_bufptr) {
if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) {
const char *const key = PL_lex_inpat ? "qr" : "q";
sv = S_new_constant(aTHX_ start, s - start, key, keylen, sv, NULL,
type, typelen);
}
- yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
} else
SvREFCNT_dec(sv);
return s;
S_intuit_more(pTHX_ register char *s)
{
dVAR;
+
+ PERL_ARGS_ASSERT_INTUIT_MORE;
+
if (PL_lex_brackets)
return TRUE;
if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
int soff;
#endif
+ PERL_ARGS_ASSERT_INTUIT_METHOD;
+
if (gv) {
if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
return 0;
return 0;
}
-/*
- * S_incl_perldb
- * Return a string of Perl code to load the debugger. If PERL5DB
- * is set, it will return the contents of that, otherwise a
- * compile-time require of perl5db.pl.
- */
-
-STATIC const char*
-S_incl_perldb(pTHX)
-{
- dVAR;
- if (PL_perldb) {
- const char * const pdb = PerlEnv_getenv("PERL5DB");
-
- if (pdb)
- return pdb;
- SETERRNO(0,SS_NORMAL);
- return "BEGIN { require 'perl5db.pl' }";
- }
- return "";
-}
-
-
/* Encoded script support. filter_add() effectively inserts a
* 'pre-processing' function into the current source input stream.
* Note that the filter function only applies to the current source file
dVAR;
SV *datasv;
+ PERL_ARGS_ASSERT_FILTER_DEL;
+
#ifdef DEBUGGING
DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
FPTR2DPTR(void*, funcp)));
#endif
: maxlen;
+ PERL_ARGS_ASSERT_FILTER_READ;
+
if (!PL_parser || !PL_rsfp_filters)
return -1;
if (idx > AvFILLp(PL_rsfp_filters)) { /* Any more filters? */
S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
{
dVAR;
+
+ PERL_ARGS_ASSERT_FILTER_GETS;
+
#ifdef PERL_CR_FILTER
if (!PL_rsfp_filters) {
filter_add(S_cr_textfilter,NULL);
}
STATIC HV *
-S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
+S_find_in_my_stash(pTHX_ const char *pkgname, STRLEN len)
{
dVAR;
GV *gv;
+ PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
+
if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
return PL_curstash;
if (gv && GvCV(gv)) {
SV * const sv = cv_const_sv(GvCV(gv));
if (sv)
- pkgname = SvPV_nolen_const(sv);
+ pkgname = SvPV_const(sv, len);
}
- return gv_stashpv(pkgname, 0);
+ return gv_stashpvn(pkgname, len, 0);
}
/*
{
GV **gvp;
GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
- yylval.ival = OP_BACKTICK;
+ pl_yylval.ival = OP_BACKTICK;
if ((gv_readpipe
&& GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
||
case FUNC0SUB:
case UNIOPSUB:
case LSTOPSUB:
- if (yylval.opval)
- append_madprops(PL_thismad, yylval.opval, 0);
+ if (pl_yylval.opval)
+ append_madprops(PL_thismad, pl_yylval.opval, 0);
PL_thismad = 0;
return optype;
}
/* Create new token struct. Note: opvals return early above. */
- yylval.tkval = newTOKEN(optype, yylval, PL_thismad);
+ pl_yylval.tkval = newTOKEN(optype, pl_yylval, PL_thismad);
PL_thismad = 0;
return optype;
}
STATIC char *
S_tokenize_use(pTHX_ int is_use, char *s) {
dVAR;
+
+ PERL_ARGS_ASSERT_TOKENIZE_USE;
+
if (PL_expect != XSTATE)
yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
is_use ? "use" : "no"));
s = force_word(s,WORD,FALSE,TRUE,FALSE);
s = force_version(s, FALSE);
}
- yylval.ival = is_use;
+ pl_yylval.ival = is_use;
return s;
}
#ifdef DEBUGGING
case LEX_KNOWNEXT:
#ifdef PERL_MAD
PL_lasttoke--;
- yylval = PL_nexttoke[PL_lasttoke].next_val;
+ pl_yylval = PL_nexttoke[PL_lasttoke].next_val;
if (PL_madskills) {
PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
PL_nexttoke[PL_lasttoke].next_mad = 0;
if (PL_thismad && PL_thismad->mad_key == '_') {
- PL_thiswhite = (SV*)PL_thismad->mad_val;
+ PL_thiswhite = MUTABLE_SV(PL_thismad->mad_val);
PL_thismad->mad_val = 0;
mad_free(PL_thismad);
PL_thismad = 0;
}
#else
PL_nexttoke--;
- yylval = PL_nextval[PL_nexttoke];
+ pl_yylval = PL_nextval[PL_nexttoke];
if (!PL_nexttoke) {
PL_lex_state = PL_lex_defer;
PL_expect = PL_lex_expect;
sv = tokeq(sv);
else if ( PL_hints & HINT_NEW_RE )
sv = new_constant(NULL, 0, "qr", sv, sv, "q", 1);
- yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
s = PL_bufend;
}
else {
if (PL_madskills) {
curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
}
- NEXTVAL_NEXTTOKE = yylval;
+ NEXTVAL_NEXTTOKE = pl_yylval;
PL_expect = XTERM;
force_next(THING);
if (PL_lex_starts++) {
if (PL_madskills)
PL_faketokens = 1;
#endif
- sv_setpv(PL_linestr,incl_perldb());
- if (SvCUR(PL_linestr))
- sv_catpvs(PL_linestr,";");
- if (PL_preambleav){
- while(AvFILLp(PL_preambleav) >= 0) {
- SV *tmpsv = av_shift(PL_preambleav);
- sv_catsv(PL_linestr, tmpsv);
+ if (PL_perldb) {
+ /* Generate a string of Perl code to load the debugger.
+ * If PERL5DB is set, it will return the contents of that,
+ * otherwise a compile-time require of perl5db.pl. */
+
+ const char * const pdb = PerlEnv_getenv("PERL5DB");
+
+ if (pdb) {
+ sv_setpv(PL_linestr, pdb);
+ sv_catpvs(PL_linestr,";");
+ } else {
+ SETERRNO(0,SS_NORMAL);
+ sv_setpvs(PL_linestr, "BEGIN { require 'perl5db.pl' };");
+ }
+ } else
+ sv_setpvs(PL_linestr,"");
+ if (PL_preambleav) {
+ SV **svp = AvARRAY(PL_preambleav);
+ SV **const end = svp + AvFILLp(PL_preambleav);
+ while(svp <= end) {
+ sv_catsv(PL_linestr, *svp);
+ ++svp;
sv_catpvs(PL_linestr, ";");
- sv_free(tmpsv);
}
- sv_free((SV*)PL_preambleav);
+ sv_free(MUTABLE_SV(PL_preambleav));
PL_preambleav = NULL;
}
+ if (PL_minus_E)
+ sv_catpvs(PL_linestr,
+ "use feature ':5." STRINGIFY(PERL_VERSION) "';");
if (PL_minus_n || PL_minus_p) {
sv_catpvs(PL_linestr, "LINE: while (<>) {");
if (PL_minus_l)
sv_catpvs(PL_linestr,"our @F=split(' ');");
}
}
- if (PL_minus_E)
- sv_catpvs(PL_linestr,"use feature ':5.10';");
sv_catpvs(PL_linestr, "\n");
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
- if (PERLDB_LINE && PL_curstash != PL_debstash)
+ if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
update_debugger_info(PL_linestr, NULL, 0);
goto retry;
}
PL_realtokenstart = -1;
#endif
if (PL_rsfp) {
- if (PL_preprocess && !PL_in_eval)
- (void)PerlProc_pclose(PL_rsfp);
- else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
+ if ((PerlIO *)PL_rsfp == PerlIO_stdin())
PerlIO_clearerr(PL_rsfp);
else
(void)PerlIO_close(PL_rsfp);
if (PL_madskills)
PL_faketokens = 1;
#endif
- sv_setpv(PL_linestr,
- (const char *)
- (PL_minus_p
- ? ";}continue{print;}" : ";}"));
+ if (PL_minus_p)
+ sv_setpvs(PL_linestr, ";}continue{print;}");
+ else
+ sv_setpvs(PL_linestr, ";}");
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
}
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
- sv_setpvn(PL_linestr,"",0);
+ sv_setpvs(PL_linestr,"");
TOKEN(';'); /* not infinite loop because rsfp is NULL now */
}
/* If it looks like the start of a BOM or raw UTF-16,
# endif
# endif
#endif
-#ifdef FTELL_FOR_PIPE_IS_BROKEN
- /* This loses the possibility to detect the bof
- * situation on perl -P when the libc5 is being used.
- * Workaround? Maybe attach some extra state to PL_rsfp?
- */
- if (!PL_preprocess)
- bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
-#else
bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
-#endif
if (bof) {
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
s = swallow_bom((U8*)s);
sv_catsv(PL_thiswhite, PL_linestr);
#endif
if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
- sv_setpvn(PL_linestr, "", 0);
+ sv_setpvs(PL_linestr, "");
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
incline(s);
} while (PL_doextract);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
- if (PERLDB_LINE && PL_curstash != PL_debstash)
+ if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
update_debugger_info(PL_linestr, NULL, 0);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
} while (argc && argv[0][0] == '-' && argv[0][1]);
init_argv_symbols(argc,argv);
}
- if ((PERLDB_LINE && !oldpdb) ||
+ if (((PERLDB_LINE || PERLDB_SAVESRC) && !oldpdb) ||
((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
/* if we have already added "LINE: while (<>) {",
we must not do it again */
{
- sv_setpvn(PL_linestr, "", 0);
+ sv_setpvs(PL_linestr, "");
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
PL_last_lop = PL_last_uni = NULL;
PL_preambled = FALSE;
- if (PERLDB_LINE)
+ if (PERLDB_LINE || PERLDB_SAVESRC)
(void)gv_fetchfile(PL_origfilename);
goto retry;
}
if (!PL_thiswhite)
PL_thiswhite = newSVpvs("");
if (CopLINE(PL_curcop) == 1) {
- sv_setpvn(PL_thiswhite, "", 0);
+ sv_setpvs(PL_thiswhite, "");
PL_faketokens = 0;
}
sv_catpvn(PL_thiswhite, s, d - s);
sv_free(sv);
if (PL_in_my == KEY_our) {
#ifdef USE_ITHREADS
- GvUNIQUE_on(cGVOPx_gv(yylval.opval));
+ GvUNIQUE_on(cGVOPx_gv(pl_yylval.opval));
#else
/* skip to avoid loading attributes.pm */
#endif
}
break;
}
- yylval.ival = CopLINE(PL_curcop);
+ pl_yylval.ival = CopLINE(PL_curcop);
if (isSPACE(*s) || *s == '#')
PL_copline = NOLINE; /* invalidate current command line number */
TOKEN('{');
if (PL_madskills) {
if (!PL_thiswhite)
PL_thiswhite = newSVpvs("");
- sv_catpvn(PL_thiswhite,"}",1);
+ sv_catpvs(PL_thiswhite,"}");
}
#endif
return yylex(); /* ignore fake brackets */
&& isIDFIRST_lazy_if(s,UTF))
{
CopLINE_dec(PL_curcop);
- Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
+ Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
CopLINE_inc(PL_curcop);
}
BAop(OP_BIT_AND);
}
else
PREREF('&');
- yylval.ival = (OPpENTERSUB_AMPER<<8);
+ pl_yylval.ival = (OPpENTERSUB_AMPER<<8);
TERM('&');
case '|':
goto leftbracket;
}
}
- yylval.ival = 0;
+ pl_yylval.ival = 0;
OPERATOR(ASSIGNOP);
case '!':
+ if (PL_expect == XSTATE && s[1] == '!' && s[2] == '!') {
+ s += 3;
+ LOP(OP_DIE,XTERM);
+ }
s++;
{
const char tmp = *s++;
/* This kludge not intended to be bulletproof. */
if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
- yylval.opval = newSVOP(OP_CONST, 0,
+ pl_yylval.opval = newSVOP(OP_CONST, 0,
newSViv(CopARYBASE_get(&PL_compiling)));
- yylval.opval->op_private = OPpCONST_ARYBASE;
+ pl_yylval.opval->op_private = OPpCONST_ARYBASE;
TERM(THING);
}
AOPERATOR(DORDOR);
}
case '?': /* may either be conditional or pattern */
- if(PL_expect == XOPERATOR) {
+ if (PL_expect == XSTATE && s[1] == '?' && s[2] == '?') {
+ s += 3;
+ LOP(OP_WARN,XTERM);
+ }
+ if (PL_expect == XOPERATOR) {
char tmp = *s++;
if(tmp == '?') {
- OPERATOR('?');
+ OPERATOR('?');
}
else {
tmp = *s++;
PL_expect = XSTATE;
goto rightbracket;
}
+ if (PL_expect == XSTATE && s[1] == '.' && s[2] == '.') {
+ s += 3;
+ OPERATOR(YADAYADA);
+ }
if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
char tmp = *s++;
if (*s == tmp) {
s++;
if (*s == tmp) {
s++;
- yylval.ival = OPf_SPECIAL;
+ pl_yylval.ival = OPf_SPECIAL;
}
else
- yylval.ival = 0;
+ pl_yylval.ival = 0;
OPERATOR(DOTDOT);
}
if (PL_expect != XOPERATOR)
/* FALL THROUGH */
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
- s = scan_num(s, &yylval);
+ s = scan_num(s, &pl_yylval);
DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
if (PL_expect == XOPERATOR)
no_op("Number",s);
}
if (!s)
missingterm(NULL);
- yylval.ival = OP_CONST;
+ pl_yylval.ival = OP_CONST;
TERM(sublex_start());
case '"':
}
if (!s)
missingterm(NULL);
- yylval.ival = OP_CONST;
+ pl_yylval.ival = OP_CONST;
/* FIXME. I think that this can be const if char *d is replaced by
more localised variables. */
for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
- yylval.ival = OP_STRINGIFY;
+ pl_yylval.ival = OP_STRINGIFY;
break;
}
}
while (isDIGIT(*start) || *start == '_')
start++;
if (*start == '.' && isDIGIT(start[1])) {
- s = scan_num(s, &yylval);
+ s = scan_num(s, &pl_yylval);
TERM(THING);
}
/* avoid v123abc() or $h{v1}, allow C<print v10;> */
else if (!isALPHA(*start) && (PL_expect == XTERM
|| PL_expect == XREF || PL_expect == XSTATE
|| PL_expect == XTERMORDORDOR)) {
- /* XXX Use gv_fetchpvn rather than stomping on a const string */
- const char c = *start;
- GV *gv;
- *start = '\0';
- gv = gv_fetchpv(s, 0, SVt_PVCV);
- *start = c;
+ GV *const gv = gv_fetchpvn_flags(s, start - s, 0, SVt_PVCV);
if (!gv) {
- s = scan_num(s, &yylval);
+ s = scan_num(s, &pl_yylval);
TERM(THING);
}
}
if (!tmp && PL_expect == XSTATE
&& d < PL_bufend && *d == ':' && *(d + 1) != ':') {
s = d + 1;
- yylval.pval = CopLABEL_alloc(PL_tokenbuf);
+ pl_yylval.pval = CopLABEL_alloc(PL_tokenbuf);
CLINE;
TOKEN(LABEL);
}
/* Is this a word before a => operator? */
if (*d == '=' && d[1] == '>') {
CLINE;
- yylval.opval
+ pl_yylval.opval
= (OP*)newSVOP(OP_CONST, 0,
S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
- yylval.opval->op_private = OPpCONST_BARE;
+ pl_yylval.opval->op_private = OPpCONST_BARE;
TERM(WORD);
}
if (PL_expect == XOPERATOR) {
if (PL_bufptr == PL_linestart) {
CopLINE_dec(PL_curcop);
- Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
+ Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), "%s", PL_warn_nosemi);
CopLINE_inc(PL_curcop);
}
else
#ifdef PERL_MAD
if (PL_madskills && !PL_thistoken) {
char *start = SvPVX(PL_linestr) + PL_realtokenstart;
- PL_thistoken = newSVpv(start,s - start);
+ PL_thistoken = newSVpvn(start,s - start);
PL_realtokenstart = s - SvPVX(PL_linestr);
}
#endif
/* Presume this is going to be a bareword of some sort. */
CLINE;
- yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
- yylval.opval->op_private = OPpCONST_BARE;
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
+ pl_yylval.opval->op_private = OPpCONST_BARE;
/* UTF-8 package name? */
if (UTF && !IN_BYTES &&
is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
/* Real typeglob, so get the real subroutine: */
? GvCVu(gv)
/* A proxy for a subroutine in this package? */
- : SvOK(gv) ? (CV *) gv : NULL)
+ : SvOK(gv) ? MUTABLE_CV(gv) : NULL)
: NULL;
/* See if it's the indirect object for a list operator. */
/* Is this a word before a => operator? */
if (*s == '=' && s[1] == '>' && !pkgname) {
CLINE;
- sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
+ sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
- SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
+ SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
TERM(WORD);
}
}
start_force(PL_curforce);
#endif
- NEXTVAL_NEXTTOKE.opval = yylval.opval;
+ NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
PL_expect = XOPERATOR;
#ifdef PERL_MAD
if (PL_madskills) {
}
#endif
force_next(WORD);
- yylval.ival = 0;
+ pl_yylval.ival = 0;
TOKEN('&');
}
/* Check for a constant sub */
if ((sv = gv_const_sv(gv))) {
its_constant:
- SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
- ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
- yylval.opval->op_private = 0;
+ SvREFCNT_dec(((SVOP*)pl_yylval.opval)->op_sv);
+ ((SVOP*)pl_yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
+ pl_yylval.opval->op_private = 0;
TOKEN(WORD);
}
cv = GvCV(gv);
}
- op_free(yylval.opval);
- yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
- yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
+ op_free(pl_yylval.opval);
+ pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
+ pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
PL_last_lop = PL_oldbufptr;
PL_last_lop_op = OP_ENTERSUB;
/* Is there a prototype? */
SvPOK(cv))
{
STRLEN protolen;
- const char *proto = SvPV_const((SV*)cv, protolen);
+ const char *proto = SvPV_const(MUTABLE_SV(cv), protolen);
if (!protolen)
TERM(FUNC0SUB);
if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
while (*proto == ';')
proto++;
if (*proto == '&' && *s == '{') {
- sv_setpv(PL_subname,
- (const char *)
- (PL_curstash ?
- "__ANON__" : "__ANON__::__ANON__"));
+ if (PL_curstash)
+ sv_setpvs(PL_subname, "__ANON__");
+ else
+ sv_setpvs(PL_subname, "__ANON__::__ANON__");
PREBLOCK(LSTOPSUB);
}
}
PL_thiswhite = 0;
}
start_force(PL_curforce);
- NEXTVAL_NEXTTOKE.opval = yylval.opval;
+ NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
PL_expect = XTERM;
if (PL_madskills) {
PL_nextwhite = nextPL_nextwhite;
}
if (probable_sub) {
gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV);
- op_free(yylval.opval);
- yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
- yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
+ op_free(pl_yylval.opval);
+ pl_yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
+ pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
PL_last_lop = PL_oldbufptr;
PL_last_lop_op = OP_ENTERSUB;
PL_nextwhite = PL_thiswhite;
PL_thiswhite = 0;
start_force(PL_curforce);
- NEXTVAL_NEXTTOKE.opval = yylval.opval;
+ NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
PL_expect = XTERM;
PL_nextwhite = nextPL_nextwhite;
curmad('X', PL_thistoken);
TOKEN(NOAMP);
}
#else
- NEXTVAL_NEXTTOKE.opval = yylval.opval;
+ NEXTVAL_NEXTTOKE.opval = pl_yylval.opval;
PL_expect = XTERM;
force_next(WORD);
TOKEN(NOAMP);
/* Call it a bare word */
+ bareword:
if (PL_hints & HINT_STRICT_SUBS)
- yylval.opval->op_private |= OPpCONST_STRICT;
+ pl_yylval.opval->op_private |= OPpCONST_STRICT;
else {
- bareword:
if (lastchar != '-') {
if (ckWARN(WARN_RESERVED)) {
d = PL_tokenbuf;
}
case KEY___FILE__:
- yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
newSVpv(CopFILE(PL_curcop),0));
TERM(THING);
case KEY___LINE__:
- yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
TERM(THING);
case KEY___PACKAGE__:
- yylval.opval = (OP*)newSVOP(OP_CONST, 0,
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0,
(PL_curstash
? newSVhek(HvNAME_HEK(PL_curstash))
: &PL_sv_undef));
#endif
/* Mark this internal pseudo-handle as clean */
IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
- if (PL_preprocess)
- IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
- else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
+ if ((PerlIO*)PL_rsfp == PerlIO_stdin())
IoTYPE(GvIOp(gv)) = IoTYPE_STD;
else
IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
s = force_word(s,WORD,TRUE,TRUE,FALSE);
if (orig_keyword == KEY_do) {
orig_keyword = 0;
- yylval.ival = 1;
+ pl_yylval.ival = 1;
}
else
- yylval.ival = 0;
+ pl_yylval.ival = 0;
OPERATOR(DO);
case KEY_die:
PREBLOCK(ELSE);
case KEY_elsif:
- yylval.ival = CopLINE(PL_curcop);
+ pl_yylval.ival = CopLINE(PL_curcop);
OPERATOR(ELSIF);
case KEY_eq:
case KEY_for:
case KEY_foreach:
- yylval.ival = CopLINE(PL_curcop);
+ pl_yylval.ival = CopLINE(PL_curcop);
s = SKIPSPACE1(s);
if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
char *p = s;
FUN0(OP_GETLOGIN);
case KEY_given:
- yylval.ival = CopLINE(PL_curcop);
+ pl_yylval.ival = CopLINE(PL_curcop);
OPERATOR(GIVEN);
case KEY_glob:
UNI(OP_HEX);
case KEY_if:
- yylval.ival = CopLINE(PL_curcop);
+ pl_yylval.ival = CopLINE(PL_curcop);
OPERATOR(IF);
case KEY_index:
UNI(OP_LCFIRST);
case KEY_local:
- yylval.ival = 0;
+ pl_yylval.ival = 0;
OPERATOR(LOCAL);
case KEY_length:
}
#endif
}
- yylval.ival = 1;
+ pl_yylval.ival = 1;
OPERATOR(MY);
case KEY_next:
LOP(OP_OPEN,XTERM);
case KEY_or:
- yylval.ival = OP_OR;
+ pl_yylval.ival = OP_OR;
OPERATOR(OROP);
case KEY_ord:
s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
missingterm(NULL);
- yylval.ival = OP_CONST;
+ pl_yylval.ival = OP_CONST;
TERM(sublex_start());
case KEY_quotemeta:
for (; !isSPACE(*d) && len; --len, ++d)
/**/;
}
- sv = newSVpvn(b, d-b);
- if (DO_UTF8(PL_lex_stuff))
- SvUTF8_on(sv);
+ sv = newSVpvn_utf8(b, d-b, DO_UTF8(PL_lex_stuff));
words = append_elem(OP_LIST, words,
newSVOP(OP_CONST, 0, tokeq(sv)));
}
s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
missingterm(NULL);
- yylval.ival = OP_STRINGIFY;
+ pl_yylval.ival = OP_STRINGIFY;
if (SvIVX(PL_lex_stuff) == '\'')
SvIV_set(PL_lex_stuff, 0); /* qq'$foo' should intepolate */
TERM(sublex_start());
}
if (orig_keyword == KEY_require) {
orig_keyword = 0;
- yylval.ival = 1;
+ pl_yylval.ival = 1;
}
else
- yylval.ival = 0;
+ pl_yylval.ival = 0;
PL_expect = XTERM;
PL_bufptr = s;
PL_last_uni = PL_oldbufptr;
case KEY_s:
s = scan_subst(s);
- if (yylval.opval)
+ if (pl_yylval.opval)
TERM(sublex_start());
else
TOKEN(1); /* force error */
(*s == ':' && s[1] == ':'))
{
#ifdef PERL_MAD
- SV *nametoke;
+ SV *nametoke = NULL;
#endif
PL_expect = XBLOCK;
Perl_croak(aTHX_ "Missing name in \"my sub\"");
PL_expect = XTERMBLOCK;
attrful = XATTRTERM;
- sv_setpvn(PL_subname,"?",1);
+ sv_setpvs(PL_subname,"?");
have_name = FALSE;
}
if (*s == '(') {
char *p;
bool bad_proto = FALSE;
+ bool in_brackets = FALSE;
+ char greedy_proto = ' ';
+ bool proto_after_greedy_proto = FALSE;
+ bool must_be_last = FALSE;
+ bool underscore = FALSE;
+ bool seen_underscore = FALSE;
const bool warnsyntax = ckWARN(WARN_SYNTAX);
s = scan_str(s,!!PL_madskills,FALSE);
for (p = d; *p; ++p) {
if (!isSPACE(*p)) {
d[tmp++] = *p;
- if (warnsyntax && !strchr("$@%*;[]&\\_", *p))
- bad_proto = TRUE;
+
+ if (warnsyntax) {
+ if (must_be_last)
+ proto_after_greedy_proto = TRUE;
+ if (!strchr("$@%*;[]&\\_", *p)) {
+ bad_proto = TRUE;
+ }
+ else {
+ if ( underscore ) {
+ if ( *p != ';' )
+ bad_proto = TRUE;
+ underscore = FALSE;
+ }
+ if ( *p == '[' ) {
+ in_brackets = TRUE;
+ }
+ else if ( *p == ']' ) {
+ in_brackets = FALSE;
+ }
+ else if ( (*p == '@' || *p == '%') &&
+ ( tmp < 2 || d[tmp-2] != '\\' ) &&
+ !in_brackets ) {
+ must_be_last = TRUE;
+ greedy_proto = *p;
+ }
+ else if ( *p == '_' ) {
+ underscore = seen_underscore = TRUE;
+ }
+ }
+ }
}
}
d[tmp] = '\0';
+ if (proto_after_greedy_proto)
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "Prototype after '%c' for %"SVf" : %s",
+ greedy_proto, SVfARG(PL_subname), d);
if (bad_proto)
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "Illegal character in prototype for %"SVf" : %s",
+ "Illegal character %sin prototype for %"SVf" : %s",
+ seen_underscore ? "after '_' " : "",
SVfARG(PL_subname), d);
SvCUR_set(PL_lex_stuff, tmp);
have_proto = TRUE;
}
#endif
if (!have_name) {
- sv_setpv(PL_subname,
- (const char *)
- (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"));
+ if (PL_curstash)
+ sv_setpvs(PL_subname, "__ANON__");
+ else
+ sv_setpvs(PL_subname, "__ANON__::__ANON__");
TOKEN(ANONSUB);
}
#ifndef PERL_MAD
UNI(OP_UNTIE);
case KEY_until:
- yylval.ival = CopLINE(PL_curcop);
+ pl_yylval.ival = CopLINE(PL_curcop);
OPERATOR(UNTIL);
case KEY_unless:
- yylval.ival = CopLINE(PL_curcop);
+ pl_yylval.ival = CopLINE(PL_curcop);
OPERATOR(UNLESS);
case KEY_unlink:
LOP(OP_VEC,XTERM);
case KEY_when:
- yylval.ival = CopLINE(PL_curcop);
+ pl_yylval.ival = CopLINE(PL_curcop);
OPERATOR(WHEN);
case KEY_while:
- yylval.ival = CopLINE(PL_curcop);
+ pl_yylval.ival = CopLINE(PL_curcop);
OPERATOR(WHILE);
case KEY_warn:
goto just_a_word;
case KEY_xor:
- yylval.ival = OP_XOR;
+ pl_yylval.ival = OP_XOR;
OPERATOR(OROP);
case KEY_y:
PADOFFSET tmp = 0;
/* pit holds the identifier we read and pending_ident is reset */
char pit = PL_pending_ident;
+ const STRLEN tokenbuf_len = strlen(PL_tokenbuf);
+ /* All routes through this function want to know if there is a colon. */
+ const char *const has_colon = (const char*) memchr (PL_tokenbuf, ':', tokenbuf_len);
PL_pending_ident = 0;
/* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
*/
if (PL_in_my) {
if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */
- if (strchr(PL_tokenbuf,':'))
+ if (has_colon)
yyerror(Perl_form(aTHX_ "No package name allowed for "
"variable %s in \"our\"",
PL_tokenbuf));
tmp = allocmy(PL_tokenbuf);
}
else {
- if (strchr(PL_tokenbuf,':'))
+ if (has_colon)
yyerror(Perl_form(aTHX_ PL_no_myglob,
PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
- yylval.opval = newOP(OP_PADANY, 0);
- yylval.opval->op_targ = allocmy(PL_tokenbuf);
+ pl_yylval.opval = newOP(OP_PADANY, 0);
+ pl_yylval.opval->op_targ = allocmy(PL_tokenbuf);
return PRIVATEREF;
}
}
(although why you'd do that is anyone's guess).
*/
- if (!strchr(PL_tokenbuf,':')) {
+ if (!has_colon) {
if (!PL_in_my)
tmp = pad_findmy(PL_tokenbuf);
if (tmp != NOT_IN_PAD) {
HEK * const stashname = HvNAME_HEK(stash);
SV * const sym = newSVhek(stashname);
sv_catpvs(sym, "::");
- sv_catpv(sym, PL_tokenbuf+1);
- yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
- yylval.opval->op_private = OPpCONST_ENTERED;
+ sv_catpvn(sym, PL_tokenbuf+1, tokenbuf_len - 1);
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
+ pl_yylval.opval->op_private = OPpCONST_ENTERED;
gv_fetchsv(sym,
(PL_in_eval
? (GV_ADDMULTI | GV_ADDINEVAL)
}
}
- yylval.opval = newOP(OP_PADANY, 0);
- yylval.opval->op_targ = tmp;
+ pl_yylval.opval = newOP(OP_PADANY, 0);
+ pl_yylval.opval->op_targ = tmp;
return PRIVATEREF;
}
}
table.
*/
if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
- GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV);
+ GV *const gv = gv_fetchpvn_flags(PL_tokenbuf + 1, tokenbuf_len - 1, 0,
+ SVt_PVAV);
if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
&& ckWARN(WARN_AMBIGUOUS)
/* DO NOT warn for @- and @+ */
}
/* build ops for a bareword */
- yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
- yylval.opval->op_private = OPpCONST_ENTERED;
- gv_fetchpv(
- PL_tokenbuf+1,
+ pl_yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn(PL_tokenbuf + 1,
+ tokenbuf_len - 1));
+ pl_yylval.opval->op_private = OPpCONST_ENTERED;
+ gv_fetchpvn_flags(
+ PL_tokenbuf + 1, tokenbuf_len - 1,
/* If the identifier refers to a stash, don't autovivify it.
* Change 24660 had the side effect of causing symbol table
* hashes to always be defined, even if they were freshly
* tests still give the expected answers, even though what
* they're actually testing has now changed subtly.
*/
- (*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'
+ (*PL_tokenbuf == '%'
+ && *(d = PL_tokenbuf + tokenbuf_len - 1) == ':'
+ && d[-1] == ':'
? 0
: PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
((PL_tokenbuf[0] == '$') ? SVt_PV
Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
{
dVAR;
+
+ PERL_ARGS_ASSERT_KEYWORD;
+
switch (len)
{
case 1: /* 5 tokens of length 1 */
{
dVAR;
+ PERL_ARGS_ASSERT_CHECKCOMMA;
+
if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
if (ckWARN(WARN_SYNTAX)) {
int level = 1;
SV *cv, *typesv;
const char *why1 = "", *why2 = "", *why3 = "";
+ PERL_ARGS_ASSERT_NEW_CONSTANT;
+
if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
SV *msg;
sv_2mortal(sv); /* Parent created it permanently */
cv = *cvp;
if (!pv && s)
- pv = sv_2mortal(newSVpvn(s, len));
+ pv = newSVpvn_flags(s, len, SVs_TEMP);
if (type && pv)
- typesv = sv_2mortal(newSVpvn(type, typelen));
+ typesv = newSVpvn_flags(type, typelen, SVs_TEMP);
else
typesv = &PL_sv_undef;
dVAR;
register char *d = dest;
register char * const e = d + destlen - 3; /* two-character token, ending NUL */
+
+ PERL_ARGS_ASSERT_SCAN_WORD;
+
for (;;) {
if (d >= e)
Perl_croak(aTHX_ ident_too_long);
register char *d = dest;
register char * const e = d + destlen + 3; /* two-character token, ending NUL */
+ PERL_ARGS_ASSERT_SCAN_IDENT;
+
if (isSPACE(*s))
s = PEEKSPACE(s);
if (isDIGIT(*s)) {
void
Perl_pmflag(pTHX_ U32* pmfl, int ch)
{
+ PERL_ARGS_ASSERT_PMFLAG;
+
PERL_UNUSED_CONTEXT;
if (ch<256) {
- char c = (char)ch;
+ const char c = (char)ch;
switch (c) {
CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break;
char *modstart;
#endif
+ PERL_ARGS_ASSERT_SCAN_PAT;
if (!s) {
const char * const delimiter = skipspace(start);
matches. */
assert(type != OP_TRANS);
if (PL_curstash) {
- MAGIC *mg = mg_find((SV*)PL_curstash, PERL_MAGIC_symtab);
+ MAGIC *mg = mg_find((const SV *)PL_curstash, PERL_MAGIC_symtab);
U32 elements;
if (!mg) {
- mg = sv_magicext((SV*)PL_curstash, 0, PERL_MAGIC_symtab, 0, 0,
+ mg = sv_magicext(MUTABLE_SV(PL_curstash), 0, PERL_MAGIC_symtab, 0, 0,
0);
}
elements = mg->mg_len / sizeof(PMOP**);
}
PL_lex_op = (OP*)pm;
- yylval.ival = OP_MATCH;
+ pl_yylval.ival = OP_MATCH;
return s;
}
char *modstart;
#endif
- yylval.ival = OP_NULL;
+ PERL_ARGS_ASSERT_SCAN_SUBST;
+
+ pl_yylval.ival = OP_NULL;
s = scan_str(start,!!PL_madskills,FALSE);
}
PL_lex_op = (OP*)pm;
- yylval.ival = OP_SUBST;
+ pl_yylval.ival = OP_SUBST;
return s;
}
register char* s;
OP *o;
short *tbl;
- I32 squash;
- I32 del;
- I32 complement;
+ U8 squash;
+ U8 del;
+ U8 complement;
#ifdef PERL_MAD
char *modstart;
#endif
- yylval.ival = OP_NULL;
+ PERL_ARGS_ASSERT_SCAN_TRANS;
+
+ pl_yylval.ival = OP_NULL;
s = scan_str(start,!!PL_madskills,FALSE);
if (!s)
(DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0);
PL_lex_op = o;
- yylval.ival = OP_TRANS;
+ pl_yylval.ival = OP_TRANS;
#ifdef PERL_MAD
if (PL_madskills) {
PL_realtokenstart = -1;
#endif
+ PERL_ARGS_ASSERT_SCAN_HEREDOC;
+
s += 2;
d = PL_tokenbuf;
e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
PL_last_lop = PL_last_uni = NULL;
}
else
- sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */
+ sv_setpvs(tmpstr,""); /* avoid "uninitialized" warning */
while (s >= PL_bufend) { /* multiple line string? */
#ifdef PERL_MAD
if (PL_madskills) {
else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
PL_bufend[-1] = '\n';
#endif
- if (PERLDB_LINE && PL_curstash != PL_debstash)
+ if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
update_debugger_info(PL_linestr, NULL, 0);
if (*s == term && memEQ(s,PL_tokenbuf,len)) {
STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
sv_recode_to_utf8(tmpstr, PL_encoding);
}
PL_lex_stuff = tmpstr;
- yylval.ival = op_type;
+ pl_yylval.ival = op_type;
return s;
}
/* scan_inputsymbol
takes: current position in input buffer
returns: new position in input buffer
- side-effects: yylval and lex_op are set.
+ side-effects: pl_yylval and lex_op are set.
This code handles:
register char *s = start; /* current position in buffer */
char *end;
I32 len;
-
char *d = PL_tokenbuf; /* start of temp holding space */
const char * const e = PL_tokenbuf + sizeof PL_tokenbuf; /* end of temp holding space */
+ PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL;
+
end = strchr(s, '\n');
if (!end)
end = PL_bufend;
*/
if (d - PL_tokenbuf != len) {
- yylval.ival = OP_GLOB;
+ pl_yylval.ival = OP_GLOB;
s = scan_str(start,!!PL_madskills,FALSE);
if (!s)
Perl_croak(aTHX_ "Glob not terminated");
}
if (!readline_overriden)
PL_lex_op->op_flags |= OPf_SPECIAL;
- /* we created the ops in PL_lex_op, so make yylval.ival a null op */
- yylval.ival = OP_NULL;
+ /* we created the ops in PL_lex_op, so make pl_yylval.ival a null op */
+ pl_yylval.ival = OP_NULL;
}
/* If it's none of the above, it must be a literal filehandle
newGVOP(OP_GV, 0, gv),
newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
: (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
- yylval.ival = OP_NULL;
+ pl_yylval.ival = OP_NULL;
}
}
char *tstart;
#endif
+ PERL_ARGS_ASSERT_SCAN_STR;
+
/* skip space before the delimiter */
if (isSPACE(*s)) {
s = PEEKSPACE(s);
CopLINE_inc(PL_curcop);
/* update debugger info */
- if (PERLDB_LINE && PL_curstash != PL_debstash)
+ if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
update_debugger_info(PL_linestr, NULL, 0);
/* having changed the buffer, we must update PL_bufend */
scan_num
takes: pointer to position in buffer
returns: pointer to new position in buffer
- side-effects: builds ops for the constant in yylval.op
+ side-effects: builds ops for the constant in pl_yylval.op
Read a number in any of the formats that Perl accepts:
const char *lastub = NULL; /* position of last underbar */
static char const number_too_long[] = "Number too long";
+ PERL_ARGS_ASSERT_SCAN_NUM;
+
/* We use the first character to decide what type of number this is */
switch (*s) {
bool eofmt = FALSE;
#ifdef PERL_MAD
char *tokenstart = s;
- SV* savewhite;
-
+ SV* savewhite = NULL;
+
if (PL_madskills) {
savewhite = PL_thiswhite;
PL_thiswhite = 0;
}
#endif
+ PERL_ARGS_ASSERT_SCAN_FORMLINE;
+
while (!needargs) {
if (*s == '.') {
t = s+1;
save_item(PL_subname);
SAVESPTR(PL_compcv);
- PL_compcv = (CV*)newSV_type(is_format ? SVt_PVFM : SVt_PVCV);
+ PL_compcv = MUTABLE_CV(newSV_type(is_format ? SVt_PVFM : SVt_PVCV));
CvFLAGS(PL_compcv) |= flags;
PL_subline = CopLINE(PL_curcop);
CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
- CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outsidecv);
+ CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outsidecv));
CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
return oldsavestack_ix;
#ifdef __SC__
#pragma segment Perl_yylex
#endif
-int
-Perl_yywarn(pTHX_ const char *s)
+static int
+S_yywarn(pTHX_ const char *const s)
{
dVAR;
+
+ PERL_ARGS_ASSERT_YYWARN;
+
PL_in_eval |= EVAL_WARNONLY;
yyerror(s);
PL_in_eval &= ~EVAL_WARNONLY;
}
int
-Perl_yyerror(pTHX_ const char *s)
+Perl_yyerror(pTHX_ const char *const s)
{
dVAR;
const char *where = NULL;
SV *msg;
int yychar = PL_parser->yychar;
+ PERL_ARGS_ASSERT_YYERROR;
+
if (!yychar || (yychar == ';' && !PL_rsfp))
where = "at EOF";
else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
where = "within string";
}
else {
- SV * const where_sv = sv_2mortal(newSVpvs("next char "));
+ SV * const where_sv = newSVpvs_flags("next char ", SVs_TEMP);
if (yychar < 32)
Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
else if (isPRINT_LC(yychar)) {
{
dVAR;
const STRLEN slen = SvCUR(PL_linestr);
+
+ PERL_ARGS_ASSERT_SWALLOW_BOM;
+
switch (s[0]) {
case 0xFF:
if (s[1] == 0xFE) {
*/
char *
-Perl_scan_vstring(pTHX_ const char *s, const char *e, SV *sv)
+Perl_scan_vstring(pTHX_ const char *s, const char *const e, SV *sv)
{
dVAR;
const char *pos = s;
const char *start = s;
+
+ PERL_ARGS_ASSERT_SCAN_VSTRING;
+
if (*pos == 'v') pos++; /* get past 'v' */
while (pos < e && (isDIGIT(*pos) || *pos == '_'))
pos++;
if (*s == 'v')
s++; /* get past 'v' */
- sv_setpvn(sv, "", 0);
+ sv_setpvs(sv, "");
for (;;) {
/* this is atoi() that tolerates underscores */