*/
#ifdef DEBUGGING /* Serve -DT. */
-# define REPORT(retval) tokereport((I32)retval)
+# define REPORT(retval) tokereport((I32)retval, &pl_yylval)
#else
# define REPORT(retval) (retval)
#endif
/* 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)pl_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[pl_yylval.ival]);
+ PL_op_name[lvalp->ival]);
break;
case TOKENTYPE_PVAL:
- Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", pl_yylval.pval);
+ Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", lvalp->pval);
break;
case TOKENTYPE_OPVAL:
- if (pl_yylval.opval) {
+ if (lvalp->opval) {
Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
- PL_op_name[pl_yylval.opval->op_type]);
- if (pl_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(pl_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);
}
*/
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
* 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[8 + MAX_FEATURE_LEN] = "feature_";
+
+ PERL_ARGS_ASSERT_FEATURE_IS_ENABLED;
+
assert(namelen <= MAX_FEATURE_LEN);
memcpy(&he_name[8], name, 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;
void
Perl_parser_free(pTHX_ const yy_parser *parser)
{
+ PERL_ARGS_ASSERT_PARSER_FREE;
+
PL_curcop = parser->saved_curcop;
SvREFCNT_dec(parser->linestr);
const char *n;
const char *e;
+ PERL_ARGS_ASSERT_INCLINE;
+
CopLINE_inc(PL_curcop);
if (*s++ != '#')
return;
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))
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);
S_lop(pTHX_ I32 f, int x, char *s)
{
dVAR;
+
+ PERL_ARGS_ASSERT_LOP;
+
pl_yylval.ival = f;
CLINE;
PL_expect = x;
S_force_next(pTHX_ I32 type)
{
dVAR;
+#ifdef DEBUGGING
+ if (DEBUG_T_TEST) {
+ PerlIO_printf(Perl_debug_log, "### forced token:\n");
+ tokereport(THING, &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;
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 == '\\') {
/* 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;
}
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);
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;
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);
dVAR;
GV *gv;
+ PERL_ARGS_ASSERT_FIND_IN_MY_STASH;
+
if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
return PL_curstash;
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"));
}
}
if (PL_minus_E)
- sv_catpvs(PL_linestr,"use feature ':5.11';");
+ sv_catpvs(PL_linestr,
+ "use feature ':5." STRINGIFY(PERL_VERSION) "';");
sv_catpvs(PL_linestr, "\n");
PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
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);
# 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);
#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;
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 == ':' && s[1] == ':'))
{
#ifdef PERL_MAD
- SV *nametoke;
+ SV *nametoke = NULL;
#endif
PL_expect = XBLOCK;
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);
char *modstart;
#endif
+ PERL_ARGS_ASSERT_SCAN_SUBST;
+
pl_yylval.ival = OP_NULL;
s = scan_str(start,!!PL_madskills,FALSE);
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
+ PERL_ARGS_ASSERT_SCAN_TRANS;
+
pl_yylval.ival = OP_NULL;
s = scan_str(start,!!PL_madskills,FALSE);
PL_realtokenstart = -1;
#endif
+ PERL_ARGS_ASSERT_SCAN_HEREDOC;
+
s += 2;
d = PL_tokenbuf;
e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
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;
char *tstart;
#endif
+ PERL_ARGS_ASSERT_SCAN_STR;
+
/* skip space before the delimiter */
if (isSPACE(*s)) {
s = PEEKSPACE(s);
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;
#pragma segment Perl_yylex
#endif
int
-Perl_yywarn(pTHX_ const char *s)
+Perl_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++;
https://perl5.git.perl.org / perl5.git / blobdiff