if (name)
Perl_sv_catpv(aTHX_ report, name);
else if ((char)rv > ' ' && (char)rv <= '~')
+ {
Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
+ if ((char)rv == 'p')
+ sv_catpvs(report, " (pending identifier)");
+ }
else if (!rv)
sv_catpvs(report, "EOF");
else
NOOP;
if (t < PL_bufptr && isSPACE(*t))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "\t(Do you need to predeclare %"SVf"?)\n",
- SVfARG(newSVpvn_flags(PL_oldoldbufptr, (STRLEN)(t - PL_oldoldbufptr),
- SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
+ "\t(Do you need to predeclare %"UTF8f"?)\n",
+ UTF8fARG(UTF, t - PL_oldoldbufptr, PL_oldoldbufptr));
}
else {
assert(s >= oldbp);
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "\t(Missing operator before %"SVf"?)\n",
- SVfARG(newSVpvn_flags(oldbp, (STRLEN)(s - oldbp),
- SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
+ "\t(Missing operator before %"UTF8f"?)\n",
+ UTF8fARG(UTF, s - oldbp, oldbp));
}
}
PL_bufptr = oldbp;
}
/*
+
+=for apidoc EXMp|bool|validate_proto|SV *name|SV *proto|bool warn
+
+This function performs syntax checking on a prototype, C<proto>.
+If C<warn> is true, any illegal characters or mismatched brackets
+will trigger illegalproto warnings, declaring that they were
+detected in the prototype for C<name>.
+
+The return value is C<true> if this is a valid prototype, and
+C<false> if it is not, regardless of whether C<warn> was C<true> or
+C<false>.
+
+Note that C<NULL> is a valid C<proto> and will always return C<true>.
+
+=cut
+
+ */
+
+bool
+Perl_validate_proto(pTHX_ SV *name, SV *proto, bool warn)
+{
+ STRLEN len, origlen;
+ char *p = proto ? SvPV(proto, len) : NULL;
+ bool bad_proto = FALSE;
+ bool in_brackets = FALSE;
+ bool after_slash = FALSE;
+ char greedy_proto = ' ';
+ bool proto_after_greedy_proto = FALSE;
+ bool must_be_last = FALSE;
+ bool underscore = FALSE;
+ bool bad_proto_after_underscore = FALSE;
+
+ PERL_ARGS_ASSERT_VALIDATE_PROTO;
+
+ if (!proto)
+ return TRUE;
+
+ origlen = len;
+ for (; len--; p++) {
+ if (!isSPACE(*p)) {
+ if (must_be_last)
+ proto_after_greedy_proto = TRUE;
+ if (underscore) {
+ if (!strchr(";@%", *p))
+ bad_proto_after_underscore = TRUE;
+ underscore = FALSE;
+ }
+ if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
+ bad_proto = TRUE;
+ }
+ else {
+ if (*p == '[')
+ in_brackets = TRUE;
+ else if (*p == ']')
+ in_brackets = FALSE;
+ else if ((*p == '@' || *p == '%') &&
+ !after_slash &&
+ !in_brackets ) {
+ must_be_last = TRUE;
+ greedy_proto = *p;
+ }
+ else if (*p == '_')
+ underscore = TRUE;
+ }
+ if (*p == '\\')
+ after_slash = TRUE;
+ else
+ after_slash = FALSE;
+ }
+ }
+
+ if (warn) {
+ SV *tmpsv = newSVpvs_flags("", SVs_TEMP);
+ p -= origlen;
+ p = SvUTF8(proto)
+ ? sv_uni_display(tmpsv, newSVpvn_flags(p, origlen, SVs_TEMP | SVf_UTF8),
+ origlen, UNI_DISPLAY_ISPRINT)
+ : pv_pretty(tmpsv, p, origlen, 60, NULL, NULL, PERL_PV_ESCAPE_NONASCII);
+
+ if (proto_after_greedy_proto)
+ Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
+ "Prototype after '%c' for %"SVf" : %s",
+ greedy_proto, SVfARG(name), p);
+ if (in_brackets)
+ Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
+ "Missing ']' in prototype for %"SVf" : %s",
+ SVfARG(name), p);
+ if (bad_proto)
+ Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
+ "Illegal character in prototype for %"SVf" : %s",
+ SVfARG(name), p);
+ if (bad_proto_after_underscore)
+ Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
+ "Illegal character after '_' in prototype for %"SVf" : %s",
+ SVfARG(name), p);
+ }
+
+ return (! (proto_after_greedy_proto || bad_proto) );
+}
+
+/*
* S_incline
* This subroutine has nothing to do with tilting, whether at windmills
* or pinball tables. Its name is short for "increment line". It
if (av) {
SV * const sv = newSV_type(SVt_PVMG);
if (orig_sv)
- sv_setsv(sv, orig_sv);
+ sv_setsv_flags(sv, orig_sv, 0); /* no cow */
else
sv_setpvn(sv, buf, len);
(void)SvIOK_on(sv);
*/
STATIC char *
-S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
+S_force_word(pTHX_ char *start, int token, int check_keyword, int allow_pack)
{
dVAR;
char *s;
start = SKIPSPACE1(start);
s = start;
if (isIDFIRST_lazy_if(s,UTF) ||
- (allow_pack && *s == ':') ||
- (allow_initial_tick && *s == '\'') )
+ (allow_pack && *s == ':') )
{
s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
- if (check_keyword && keyword(PL_tokenbuf, len, 0))
+ if (check_keyword) {
+ char *s2 = PL_tokenbuf;
+ if (allow_pack && len > 6 && strnEQ(s2, "CORE::", 6))
+ s2 += 6, len -= 6;
+ if (keyword(s2, len, 0))
return start;
+ }
start_force(PL_curforce);
if (PL_madskills)
curmad('X', newSVpvn(start,s-start));
if (! isCHARNAME_CONT(*s)) {
goto bad_charname;
}
- if (*s == ' ' && *(s-1) == ' ' && ckWARN(WARN_DEPRECATED)) {
- Perl_warn(aTHX_ "A sequence of multiple spaces in a charnames alias definition is deprecated");
+ if (*s == ' ' && *(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
+ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ "A sequence of multiple spaces in a charnames "
+ "alias definition is deprecated");
}
s++;
}
- if (*(s-1) == ' ' && ckWARN(WARN_DEPRECATED)) {
- Perl_warn(aTHX_ "Trailing white-space in a charnames alias definition is deprecated");
+ if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
+ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ "Trailing white-space in a charnames alias "
+ "definition is deprecated");
}
}
else {
if (! isCHARNAME_CONT(*s)) {
goto bad_charname;
}
- if (*s == ' ' && *(s-1) == ' ' && ckWARN(WARN_DEPRECATED)) {
- Perl_warn(aTHX_ "A sequence of multiple spaces in a charnames alias definition is deprecated");
+ if (*s == ' ' && *(s-1) == ' '
+ && ckWARN_d(WARN_DEPRECATED)) {
+ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ "A sequence of multiple spaces in a charnam"
+ "es alias definition is deprecated");
}
s++;
}
s += UTF8SKIP(s);
}
}
- if (*(s-1) == ' ' && ckWARN(WARN_DEPRECATED)) {
- Perl_warn(aTHX_ "Trailing white-space in a charnames alias definition is deprecated");
+ if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
+ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ "Trailing white-space in a charnames alias "
+ "definition is deprecated");
}
}
if (gv && SvTYPE(gv) == SVt_PVGV && GvIO(gv))
return 0;
if (cv && SvPOK(cv)) {
- const char *proto = CvPROTO(cv);
- if (proto) {
- if (*proto == ';')
- proto++;
- if (*proto == '*')
- return 0;
- }
+ const char *proto = CvPROTO(cv);
+ if (proto) {
+ while (*proto && (isSPACE(*proto) || *proto == ';'))
+ proto++;
+ if (*proto == '*')
+ return 0;
+ }
}
- s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
- /* start is the beginning of the possible filehandle/object,
- * and s is the end of it
- * tmpbuf is a copy of it
- */
if (*start == '$') {
if (cv || PL_last_lop_op == OP_PRINT || PL_last_lop_op == OP_SAY ||
PL_expect = XREF;
return *s == '(' ? FUNCMETH : METHOD;
}
+
+ s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
+ /* start is the beginning of the possible filehandle/object,
+ * and s is the end of it
+ * tmpbuf is a copy of it (but with single quotes as double colons)
+ */
+
if (!keyword(tmpbuf, len, 0)) {
if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
len -= 2;
force_next(WORD);
}
else if (*s == 'v') {
- s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ s = force_word(s,WORD,FALSE,TRUE);
s = force_version(s, FALSE);
}
}
else {
- s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ s = force_word(s,WORD,FALSE,TRUE);
s = force_version(s, FALSE);
}
pl_yylval.ival = is_use;
char *d;
STRLEN len;
bool bof = FALSE;
+ const bool saw_infix_sigil = PL_parser->saw_infix_sigil;
U8 formbrack = 0;
U32 fake_eof = 0;
s = PL_bufptr;
PL_oldoldbufptr = PL_oldbufptr;
PL_oldbufptr = s;
+ PL_parser->saw_infix_sigil = 0;
retry:
#ifdef PERL_MAD
s++;
if (strnEQ(s,"=>",2)) {
- s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
+ s = force_word(PL_bufptr,WORD,FALSE,FALSE);
DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
OPERATOR('-'); /* unary minus */
}
s++;
s = SKIPSPACE1(s);
if (isIDFIRST_lazy_if(s,UTF)) {
- s = force_word(s,METHOD,FALSE,TRUE,FALSE);
+ s = force_word(s,METHOD,FALSE,TRUE);
TOKEN(ARROW);
}
else if (*s == '$')
s--;
TOKEN(0);
}
+ PL_parser->saw_infix_sigil = 1;
Mop(OP_MULTIPLY);
case '%':
PL_lex_fakeeof >= LEX_FAKEEOF_ASSIGN)
TOKEN(0);
++s;
+ PL_parser->saw_infix_sigil = 1;
Mop(OP_MODULO);
}
PL_tokenbuf[0] = '%';
d++;
if (*d == '}') {
const char minus = (PL_tokenbuf[0] == '-');
- s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
+ s = force_word(s + minus, WORD, FALSE, TRUE);
if (minus)
force_next('-');
}
s--;
TOKEN(0);
}
+ PL_parser->saw_infix_sigil = 1;
BAop(OP_BIT_AND);
}
if (*t == ';'
&& get_cvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0))
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "You need to quote \"%"SVf"\"",
- SVfARG(newSVpvn_flags(tmpbuf, len,
- SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
+ "You need to quote \"%"UTF8f"\"",
+ UTF8fARG(UTF, len, tmpbuf));
}
}
}
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 %"SVf" better written as $%"SVf,
- SVfARG(newSVpvn_flags(PL_bufptr, (STRLEN)(t-PL_bufptr),
- SVs_TEMP | (UTF ? SVf_UTF8 : 0 ))),
- SVfARG(newSVpvn_flags(PL_bufptr+1, (STRLEN)(t-PL_bufptr-1),
- SVs_TEMP | (UTF ? SVf_UTF8 : 0 ))));
+ "Scalar value %"UTF8f" better written as $%"UTF8f,
+ UTF8fARG(UTF, t-PL_bufptr, PL_bufptr),
+ UTF8fARG(UTF, t-PL_bufptr-1, PL_bufptr+1));
}
}
}
else {
rv2cv_op = newOP(OP_PADANY, 0);
rv2cv_op->op_targ = off;
- rv2cv_op = (OP*)newCVREF(0, rv2cv_op);
- cv = (CV *)PAD_SV(off);
+ cv = find_lexical_cv(off);
}
lex = TRUE;
goto just_a_word;
s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
TRUE, &morelen);
if (!morelen)
- Perl_croak(aTHX_ "Bad name after %"SVf"%s",
- SVfARG(newSVpvn_flags(PL_tokenbuf, len,
- (UTF ? SVf_UTF8 : 0) | SVs_TEMP )),
+ Perl_croak(aTHX_ "Bad name after %"UTF8f"%s",
+ UTF8fARG(UTF, len, PL_tokenbuf),
*s == '\'' ? "'" : "::");
len += morelen;
pkgname = 1;
if (ckWARN(WARN_BAREWORD)
&& ! gv_fetchpvn_flags(PL_tokenbuf, len, UTF ? SVf_UTF8 : 0, SVt_PVHV))
Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
- "Bareword \"%"SVf"\" refers to nonexistent package",
- SVfARG(newSVpvn_flags(PL_tokenbuf, len,
- (UTF ? SVf_UTF8 : 0) | SVs_TEMP)));
+ "Bareword \"%"UTF8f"\" refers to nonexistent package",
+ UTF8fARG(UTF, len, PL_tokenbuf));
len -= 2;
PL_tokenbuf[len] = '\0';
gv = NULL;
if (*s == '=' && s[1] == '>' && !pkgname) {
op_free(rv2cv_op);
CLINE;
+ /* This is our own scalar, created a few lines above,
+ so this is safe. */
+ SvREADONLY_off(cSVOPx(pl_yylval.opval)->op_sv);
sv_setpv(((SVOP*)pl_yylval.opval)->op_sv, PL_tokenbuf);
if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
SvUTF8_on(((SVOP*)pl_yylval.opval)->op_sv);
+ SvREADONLY_on(cSVOPx(pl_yylval.opval)->op_sv);
TERM(WORD);
}
if (cv) {
if (lastchar == '-' && penultchar != '-') {
- const SV *tmpsv = newSVpvn_flags( PL_tokenbuf, len ? len : strlen(PL_tokenbuf), (UTF ? SVf_UTF8 : 0) | SVs_TEMP );
+ const STRLEN l = len ? len : strlen(PL_tokenbuf);
Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Ambiguous use of -%"SVf" resolved as -&%"SVf"()",
- SVfARG(tmpsv), SVfARG(tmpsv));
+ "Ambiguous use of -%"UTF8f" resolved as -&%"UTF8f"()",
+ UTF8fARG(UTF, l, PL_tokenbuf),
+ UTF8fARG(UTF, l, PL_tokenbuf));
}
/* Check for a constant sub */
if ((sv = cv_const_sv(cv))) {
}
op_free(pl_yylval.opval);
- pl_yylval.opval = rv2cv_op;
+ pl_yylval.opval =
+ off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
PL_last_lop = PL_oldbufptr;
PL_last_lop_op = OP_ENTERSUB;
STRLEN protolen = CvPROTOLEN(cv);
const char *proto = CvPROTO(cv);
bool optional;
+ proto = S_strip_spaces(aTHX_ proto, &protolen);
if (!protolen)
TERM(FUNC0SUB);
if ((optional = *proto == ';'))
gv = gv_fetchpv(PL_tokenbuf, GV_ADD | ( UTF ? SVf_UTF8 : 0 ),
SVt_PVCV);
op_free(pl_yylval.opval);
- pl_yylval.opval = rv2cv_op;
+ pl_yylval.opval =
+ off ? (OP *)newCVREF(0, rv2cv_op) : rv2cv_op;
pl_yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
PL_last_lop = PL_oldbufptr;
PL_last_lop_op = OP_ENTERSUB;
op_free(rv2cv_op);
safe_bareword:
- if ((lastchar == '*' || lastchar == '%' || lastchar == '&')) {
+ if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
+ && saw_infix_sigil) {
Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Operator or semicolon missing before %c%"SVf,
- lastchar, SVfARG(newSVpvn_flags(PL_tokenbuf,
- strlen(PL_tokenbuf),
- SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
+ "Operator or semicolon missing before %c%"UTF8f,
+ lastchar,
+ UTF8fARG(UTF, strlen(PL_tokenbuf),
+ PL_tokenbuf));
Perl_ck_warner_d(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous use of %c resolved as operator %c",
lastchar, lastchar);
goto just_a_word;
}
if (!tmp)
- Perl_croak(aTHX_ "CORE::%"SVf" is not a keyword",
- SVfARG(newSVpvn_flags(PL_tokenbuf, len,
- (UTF ? SVf_UTF8 : 0) | SVs_TEMP)));
+ Perl_croak(aTHX_ "CORE::%"UTF8f" is not a keyword",
+ UTF8fARG(UTF, len, PL_tokenbuf));
if (tmp < 0)
tmp = -tmp;
else if (tmp == KEY_require || tmp == KEY_do
case KEY_dump:
PL_expect = XOPERATOR;
- s = force_word(s,WORD,TRUE,FALSE,FALSE);
+ s = force_word(s,WORD,TRUE,FALSE);
LOOPX(OP_DUMP);
case KEY_else:
case KEY_goto:
PL_expect = XOPERATOR;
- s = force_word(s,WORD,TRUE,FALSE,FALSE);
+ s = force_word(s,WORD,TRUE,FALSE);
LOOPX(OP_GOTO);
case KEY_gmtime:
case KEY_last:
PL_expect = XOPERATOR;
- s = force_word(s,WORD,TRUE,FALSE,FALSE);
+ s = force_word(s,WORD,TRUE,FALSE);
LOOPX(OP_LAST);
case KEY_lc:
case KEY_next:
PL_expect = XOPERATOR;
- s = force_word(s,WORD,TRUE,FALSE,FALSE);
+ s = force_word(s,WORD,TRUE,FALSE);
LOOPX(OP_NEXT);
case KEY_ne:
&& !(t[0] == ':' && t[1] == ':')
&& !keyword(s, d-s, 0)
) {
- SV *tmpsv = newSVpvn_flags(s, (STRLEN)(d-s),
- SVs_TEMP | (UTF ? SVf_UTF8 : 0));
Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
- "Precedence problem: open %"SVf" should be open(%"SVf")",
- SVfARG(tmpsv), SVfARG(tmpsv));
+ "Precedence problem: open %"UTF8f" should be open(%"UTF8f")",
+ UTF8fARG(UTF, d-s, s), UTF8fARG(UTF, d-s, s));
}
}
LOP(OP_OPEN,XTERM);
LOP(OP_PACK,XTERM);
case KEY_package:
- s = force_word(s,WORD,FALSE,TRUE,FALSE);
+ s = force_word(s,WORD,FALSE,TRUE);
s = SKIPSPACE1(s);
s = force_strict_version(s);
PL_lex_expect = XBLOCK;
|| (s = force_version(s, TRUE), *s == 'v'))
{
*PL_tokenbuf = '\0';
- s = force_word(s,WORD,TRUE,TRUE,FALSE);
+ s = force_word(s,WORD,TRUE,TRUE);
if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
GV_ADD | (UTF ? SVf_UTF8 : 0));
case KEY_redo:
PL_expect = XOPERATOR;
- s = force_word(s,WORD,TRUE,FALSE,FALSE);
+ s = force_word(s,WORD,TRUE,FALSE);
LOOPX(OP_REDO);
case KEY_rename:
checkcomma(s,PL_tokenbuf,"subroutine name");
s = SKIPSPACE1(s);
PL_expect = XTERM;
- s = force_word(s,WORD,TRUE,TRUE,FALSE);
+ s = force_word(s,WORD,TRUE,TRUE);
LOP(OP_SORT,XREF);
case KEY_split:
really_sub:
{
char * const tmpbuf = PL_tokenbuf + 1;
- SSize_t tboffset = 0;
expectation attrful;
bool have_name, have_proto;
const int key = tmp;
+#ifndef PERL_MAD
+ SV *format_name = NULL;
+#endif
#ifdef PERL_MAD
SV *tmpwhite = 0;
PL_expect = XBLOCK;
attrful = XATTRBLOCK;
- /* remember buffer pos'n for later force_word */
- tboffset = s - PL_oldbufptr;
d = scan_word(s, tmpbuf, sizeof PL_tokenbuf - 1, TRUE,
&len);
#ifdef PERL_MAD
if (PL_madskills)
nametoke = newSVpvn_flags(s, d - s, SvUTF8(PL_linestr));
+#else
+ if (key == KEY_format)
+ format_name = S_newSV_maybe_utf8(aTHX_ s, d - s);
#endif
*PL_tokenbuf = '&';
if (memchr(tmpbuf, ':', len) || key != KEY_sub
#ifdef PERL_MAD
PL_thistoken = subtoken;
s = d;
- PERL_UNUSED_VAR(tboffset);
#else
- if (have_name)
- (void) force_word(PL_oldbufptr + tboffset, WORD,
- FALSE, TRUE, TRUE);
+ if (format_name) {
+ start_force(PL_curforce);
+ NEXTVAL_NEXTTOKE.opval
+ = (OP*)newSVOP(OP_CONST,0, format_name);
+ NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
+ force_next(WORD);
+ }
#endif
PREBLOCK(FORMAT);
}
/* Look for a prototype */
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 warnillegalproto = ckWARN(WARN_ILLEGALPROTO);
- STRLEN tmplen;
-
s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
if (!s)
Perl_croak(aTHX_ "Prototype not terminated");
- /* strip spaces and check for bad characters */
- d = SvPV(PL_lex_stuff, tmplen);
- tmp = 0;
- for (p = d; tmplen; tmplen--, ++p) {
- if (!isSPACE(*p)) {
- d[tmp++] = *p;
-
- if (warnillegalproto) {
- if (must_be_last)
- proto_after_greedy_proto = TRUE;
- if (!strchr("$@%*;[]&\\_+", *p) || *p == '\0') {
- bad_proto = TRUE;
- }
- else {
- if ( underscore ) {
- if ( !strchr(";@%", *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_ILLEGALPROTO),
- "Prototype after '%c' for %"SVf" : %s",
- greedy_proto, SVfARG(PL_subname), d);
- if (bad_proto) {
- SV *dsv = newSVpvs_flags("", SVs_TEMP);
- Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
- "Illegal character %sin prototype for %"SVf" : %s",
- seen_underscore ? "after '_' " : "",
- SVfARG(PL_subname),
- SvUTF8(PL_lex_stuff)
- ? sv_uni_display(dsv,
- newSVpvn_flags(d, tmp, SVs_TEMP | SVf_UTF8),
- tmp,
- UNI_DISPLAY_ISPRINT)
- : pv_pretty(dsv, d, tmp, 60, NULL, NULL,
- PERL_PV_ESCAPE_NONASCII));
- }
- SvCUR_set(PL_lex_stuff, tmp);
+ (void)validate_proto(PL_subname, PL_lex_stuff, ckWARN(WARN_ILLEGALPROTO));
have_proto = TRUE;
#ifdef PERL_MAD
{
/* Downgraded from fatal to warning 20000522 mjd */
Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
- "Possible unintended interpolation of %"SVf" in string",
- SVfARG(newSVpvn_flags(PL_tokenbuf, tokenbuf_len,
- SVs_TEMP | ( UTF ? SVf_UTF8 : 0 ))));
+ "Possible unintended interpolation of %"UTF8f
+ " in string",
+ UTF8fARG(UTF, tokenbuf_len, PL_tokenbuf));
}
}
*d = '\0';
d = dest;
if (*d) {
+ /* Either a digit variable, or parse_ident() found an identifier
+ (anything valid as a bareword), so job done and return. */
if (PL_lex_state != LEX_NORMAL)
PL_lex_state = LEX_INTERPENDMAYBE;
return s;
|| s[1] == '{'
|| strnEQ(s+1,"::",2)) )
{
+ /* Dereferencing a value in a scalar variable.
+ The alternatives are different syntaxes for a scalar variable.
+ Using ' as a leading package separator isn't allowed. :: is. */
return s;
}
+ /* Handle the opening { of @{...}, &{...}, *{...}, %{...}, ${...} */
if (*s == '{') {
bracket = s;
s++;
s++;
}
-#define VALID_LEN_ONE_IDENT(d, u) (isPUNCT_A((U8)*(d)) \
- || isCNTRL_A((U8)*(d)) \
- || isDIGIT_A((U8)*(d)) \
- || (!(u) && !UTF8_IS_INVARIANT((U8)*(d))))
+#define VALID_LEN_ONE_IDENT(d, u) (isPUNCT_A((U8)(d)) \
+ || isCNTRL_A((U8)(d)) \
+ || isDIGIT_A((U8)(d)) \
+ || (!(u) && !UTF8_IS_INVARIANT((U8)(d))))
if (s < send
- && (isIDFIRST_lazy_if(s, is_utf8) || VALID_LEN_ONE_IDENT(s, is_utf8)))
+ && (isIDFIRST_lazy_if(s, is_utf8) || VALID_LEN_ONE_IDENT(*s, is_utf8)))
{
if (is_utf8) {
const STRLEN skip = UTF8SKIP(s);
d[1] = '\0';
}
}
+ /* Convert $^F, ${^F} and the ^F of ${^FOO} to control characters */
if (*d == '^' && *s && isCONTROLVAR(*s)) {
*d = toCTRL(*s);
s++;
}
+ /* Warn about ambiguous code after unary operators if {...} notation isn't
+ used. There's no difference in ambiguity; it's merely a heuristic
+ about when not to warn. */
else if (ck_uni && !bracket)
check_uni();
if (bracket) {
+ /* If we were processing {...} notation then... */
if (isIDFIRST_lazy_if(d,is_utf8)) {
+ /* if it starts as a valid identifier, assume that it is one.
+ (the later check for } being at the expected point will trap
+ cases where this doesn't pan out.) */
d += is_utf8 ? UTF8SKIP(d) : 1;
parse_ident(&s, &d, e, 1, is_utf8);
*d = '\0';
while (s < send && SPACE_OR_TAB(*s))
s++;
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
+ /* ${foo[0]} and ${foo{bar}} notation. */
if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
const char * const brack =
(const char *)
}
/* Handle extended ${^Foo} variables
* 1999-02-27 mjd-perl-patch@plover.com */
- else if (!isWORDCHAR(*d) && !isPRINT(*d) /* isCTRL(d) */
+ else if (! isPRINT(*d) /* isCNTRL(d), plus all non-ASCII */
&& isWORDCHAR(*s))
{
d++;
while (s < send && SPACE_OR_TAB(*s))
s++;
+ /* Expect to find a closing } after consuming any trailing whitespace.
+ */
if (*s == '}') {
s++;
if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
}
}
else {
+ /* Didn't find the closing } at the point we expected, so restore
+ state such that the next thing to process is the opening { and */
s = bracket; /* let the parser handle it */
*dest = '\0';
}
Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
if (context)
- Perl_sv_catpvf(aTHX_ msg, "near \"%"SVf"\"\n",
- SVfARG(newSVpvn_flags(context, contlen,
- SVs_TEMP | (UTF ? SVf_UTF8 : 0))));
+ Perl_sv_catpvf(aTHX_ msg, "near \"%"UTF8f"\"\n",
+ UTF8fARG(UTF, contlen, context));
else
Perl_sv_catpvf(aTHX_ msg, "%"SVf"\n", SVfARG(where_sv));
if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
https://perl5.git.perl.org / perl5.git / blobdiff