PERL_ARGS_ASSERT_PRINTBUF;
+ GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
+ GCC_DIAG_RESTORE;
SvREFCNT_dec(tmp);
}
Direct pointer to the end of the chunk of text currently being lexed, the
end of the lexer buffer. This is equal to C<SvPVX(PL_parser-E<gt>linestr)
-+ SvCUR(PL_parser-E<gt>linestr)>. A NUL character (zero octet) is
++ SvCUR(PL_parser-E<gt>linestr)>. A C<NUL> character (zero octet) is
always located at the end of the buffer, and does not count as part of
the buffer's contents.
=for apidoc Amx|char *|lex_grow_linestr|STRLEN len
Reallocates the lexer buffer (L</PL_parser-E<gt>linestr>) to accommodate
-at least I<len> octets (including terminating NUL). Returns a
+at least I<len> octets (including terminating C<NUL>). Returns a
pointer to the reallocated buffer. This is necessary before making
any direct modification of the buffer that would increase its length.
L</lex_stuff_pvn> provides a more convenient way to insert text into
*/
static int
-S_postderef(pTHX_ char const funny, char const next)
+S_postderef(pTHX_ int const funny, char const next)
{
dVAR;
- assert(strchr("$@%&*", funny));
+ assert(funny == DOLSHARP || strchr("$@%&*", funny));
assert(strchr("*[{", next));
if (next == '*') {
PL_expect = XOPERATOR;
if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
- assert('@' == funny || '$' == funny);
+ assert('@' == funny || '$' == funny || DOLSHARP == funny);
PL_lex_state = LEX_INTERPEND;
start_force(PL_curforce);
force_next(POSTJOIN);
#endif
if (*d == ';' || isSPACE(*d) || *d == '{' || *d == '}' || !*d) {
SV *ver;
-#ifdef USE_LOCALE_NUMERIC
- char *loc = savepv(setlocale(LC_NUMERIC, NULL));
- setlocale(LC_NUMERIC, "C");
-#endif
s = scan_num(s, &pl_yylval);
-#ifdef USE_LOCALE_NUMERIC
- setlocale(LC_NUMERIC, loc);
- Safefree(loc);
-#endif
version = pl_yylval.opval;
ver = cSVOPx(version)->op_sv;
if (SvPOK(ver) && !SvNIOK(ver)) {
/* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
assert(PL_lex_inwhat != OP_TRANSR);
- if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
+ if (PL_lex_repl) {
+ assert (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS);
PL_linestr = PL_lex_repl;
PL_lex_inpat = 0;
PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
* look to see that the first character is legal. Then loop through the
* rest checking that each is a continuation */
- /* This code needs to be sync'ed with a regex in _charnames.pm which does
- * the same thing */
+ /* This code makes the reasonable assumption that the only Latin1-range
+ * characters that begin a character name alias are alphabetic, otherwise
+ * would have to create a isCHARNAME_BEGIN macro */
if (! UTF) {
if (! isALPHAU(*s)) {
if (! isCHARNAME_CONT(*s)) {
goto bad_charname;
}
- if (*s == ' ' && *(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
+ if (*s == ' ' && *(s-1) == ' ') {
+ goto multi_spaces;
+ }
+ if ((U8) *s == NBSP_NATIVE && ckWARN_d(WARN_DEPRECATED)) {
Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
- "A sequence of multiple spaces in a charnames "
+ "NO-BREAK SPACE in a charnames "
"alias definition is deprecated");
}
s++;
}
- if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
- Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
- "Trailing white-space in a charnames alias "
- "definition is deprecated");
- }
}
else {
/* Similarly for utf8. For invariants can check directly; for other
if (! isCHARNAME_CONT(*s)) {
goto bad_charname;
}
- 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");
+ if (*s == ' ' && *(s-1) == ' ') {
+ goto multi_spaces;
}
s++;
}
{
goto bad_charname;
}
+ if (*s == *NBSP_UTF8
+ && *(s+1) == *(NBSP_UTF8+1)
+ && ckWARN_d(WARN_DEPRECATED))
+ {
+ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ "NO-BREAK SPACE in a charnames "
+ "alias definition is deprecated");
+ }
s += 2;
}
else {
s += UTF8SKIP(s);
}
}
- if (*(s-1) == ' ' && ckWARN_d(WARN_DEPRECATED)) {
- Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
- "Trailing white-space in a charnames alias "
- "definition is deprecated");
- }
+ }
+ if (*(s-1) == ' ') {
+ yyerror_pv(
+ Perl_form(aTHX_
+ "charnames alias definitions may not contain trailing "
+ "white-space; marked by <-- HERE in %.*s<-- HERE %.*s",
+ (int)(s - backslash_ptr + 1), backslash_ptr,
+ (int)(e - s + 1), s + 1
+ ),
+ UTF ? SVf_UTF8 : 0);
+ return NULL;
}
if (SvUTF8(res)) { /* Don't accept malformed input */
return res;
bad_charname: {
- int bad_char_size = ((UTF) ? UTF8SKIP(s) : 1);
/* The final %.*s makes sure that should the trailing NUL be missing
* that this print won't run off the end of the string */
yyerror_pv(
Perl_form(aTHX_
"Invalid character in \\N{...}; marked by <-- HERE in %.*s<-- HERE %.*s",
- (int)(s - backslash_ptr + bad_char_size), backslash_ptr,
- (int)(e - s + bad_char_size), s + bad_char_size
+ (int)(s - backslash_ptr + 1), backslash_ptr,
+ (int)(e - s + 1), s + 1
),
UTF ? SVf_UTF8 : 0);
return NULL;
}
+
+ multi_spaces:
+ yyerror_pv(
+ Perl_form(aTHX_
+ "charnames alias definitions may not contain a sequence of "
+ "multiple spaces; marked by <-- HERE in %.*s<-- HERE %.*s",
+ (int)(s - backslash_ptr + 1), backslash_ptr,
+ (int)(e - s + 1), s + 1
+ ),
+ UTF ? SVf_UTF8 : 0);
+ return NULL;
}
/*
if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
{
+ /* diag_listed_as: \%d better written as $%d */
Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
*--s = '$';
break;
*d++ = *s++;
continue;
}
- /* FALL THROUGH */
+ /* FALLTHROUGH */
default:
{
if ((isALPHANUMERIC(*s)))
if (! PL_lex_inpat) {
yyerror("Missing right brace on \\N{}");
} else {
- yyerror("Missing right brace on \\N{} or unescaped left brace after \\N.");
+ yyerror("Missing right brace on \\N{} or unescaped left brace after \\N");
}
continue;
}
const STRLEN off = d - SvPVX_const(sv);
d = off + SvGROW(sv, off + len + (STRLEN)(send - s) + 1);
}
+ if (! SvUTF8(res)) { /* Make sure is \N{} return is UTF-8 */
+ sv_utf8_upgrade(res);
+ str = SvPV_const(res, len);
+ }
Copy(str, d, len, char);
d += len;
}
case 'c':
s++;
if (s < send) {
- *d++ = grok_bslash_c(*s++, has_utf8, 1);
+ *d++ = grok_bslash_c(*s++, 1);
}
else {
yyerror("Missing control char name in \\c");
* It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
*
* ->[ and ->{ return TRUE
- * ->$* ->@* ->@[ and ->@{ return TRUE if postfix_interpolate is enabled
+ * ->$* ->$#* ->@* ->@[ ->@{ return TRUE if postderef_qq is enabled
* { and [ outside a pattern are always subscripts, so return TRUE
* if we're outside a pattern and it's not { or [, then return FALSE
* if we're in a pattern and the first char is a {
return TRUE;
if (*s == '-' && s[1] == '>'
&& FEATURE_POSTDEREF_QQ_IS_ENABLED
- && ( (s[2] == '$' && s[3] == '*')
+ && ( (s[2] == '$' && (s[3] == '*' || (s[3] == '#' && s[4] == '*')))
||(s[2] == '@' && strchr("*[{",s[3])) ))
return TRUE;
if (*s != '{' && *s != '[')
PL_lex_state = LEX_INTERPNORMAL; /* false alarm, more expr */
break;
}
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case LEX_INTERPEND:
if (PL_lex_dojoin) {
s = SKIPSPACE1(s);
if (FEATURE_POSTDEREF_IS_ENABLED && (
((*s == '$' || *s == '&') && s[1] == '*')
+ ||(*s == '$' && s[1] == '#' && s[2] == '*')
||((*s == '@' || *s == '%') && strchr("*[{", s[1]))
||(*s == '*' && (s[1] == '*' || s[1] == '{'))
))
}
sv = newSVpvn_flags(s, len, UTF ? SVf_UTF8 : 0);
if (*d == '(') {
- d = scan_str(d,TRUE,TRUE,FALSE, FALSE);
+ d = scan_str(d,TRUE,TRUE,FALSE,FALSE,NULL);
COPLINE_SET_FROM_MULTI_END;
if (!d) {
/* MUST advance bufptr here to avoid bogus
/* XXX losing whitespace on sequential attributes here */
}
{
- const char tmp
- = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
- if (*s != ';' && *s != '}' && *s != tmp
- && (tmp != '=' || *s != ')')) {
+ if (*s != ';' && *s != '}' &&
+ !(PL_expect == XOPERATOR
+ ? (*s == '=' || *s == ')')
+ : (*s == '{' || *s == '('))) {
const char q = ((*s == '\'') ? '"' : '\'');
/* If here for an expression, and parsed no attrs, back
off. */
- if (tmp == '=' && !attrs) {
+ if (PL_expect == XOPERATOR && !attrs) {
s = PL_bufptr;
break;
}
TOKEN(0);
s++;
if (PL_lex_brackets <= 0)
+ /* diag_listed_as: Unmatched right %s bracket */
yyerror("Unmatched right square bracket");
else
--PL_lex_brackets;
force_next('-');
}
}
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case XATTRBLOCK:
case XBLOCK:
PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
rightbracket:
s++;
if (PL_lex_brackets <= 0)
+ /* diag_listed_as: Unmatched right %s bracket */
yyerror("Unmatched right curly bracket");
else
PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
return deprecate_commaless_var_list();
}
}
- else if (PL_expect == XPOSTDEREF) POSTDEREF('$');
+ else if (PL_expect == XPOSTDEREF) {
+ if (s[1] == '#') {
+ s++;
+ POSTDEREF(DOLSHARP);
+ }
+ POSTDEREF('$');
+ }
if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-@", s[2]))) {
PL_tokenbuf[0] = '@';
s += 2;
AOPERATOR(DORDOR);
}
+ /* FALLTHROUGH */
case '?': /* may either be conditional or pattern */
if (PL_expect == XOPERATOR) {
char tmp = *s++;
}
Aop(OP_CONCAT);
}
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
s = scan_num(s, &pl_yylval);
TERM(THING);
case '\'':
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
+ if (!s)
+ missingterm(NULL);
COPLINE_SET_FROM_MULTI_END;
DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
if (PL_expect == XOPERATOR) {
else
no_op("String",s);
}
- if (!s)
- missingterm(NULL);
pl_yylval.ival = OP_CONST;
TERM(sublex_start());
case '"':
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
DEBUG_T( {
if (s)
printbuf("### Saw string before %s\n", s);
TERM(sublex_start());
case '`':
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
if (PL_expect == XOPERATOR)
no_op("Backticks",s);
if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
CV *cv;
if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len,
- UTF ? SVf_UTF8 : 0, SVt_PVCV)) &&
+ (UTF ? SVf_UTF8 : 0)|GV_NOTQUAL,
+ SVt_PVCV)) &&
(cv = GvCVu(gv)))
{
if (GvIMPORTED_CV(gv))
while (isLOWER(*d))
d++;
if (!*d && !gv_stashpv(PL_tokenbuf, UTF ? SVf_UTF8 : 0))
+ {
+ /* PL_warn_reserved is constant */
+ GCC_DIAG_IGNORE(-Wformat-nonliteral);
Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
PL_tokenbuf);
+ GCC_DIAG_RESTORE;
+ }
}
}
}
ENTER;
SAVETMPS;
PUSHMARK(sp);
- EXTEND(SP, 1);
XPUSHs(PL_encoding);
PUTBACK;
call_method("name", G_SCALAR);
*PL_tokenbuf = '&';
d = scan_word(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
1, &len);
- if (len && !keyword(PL_tokenbuf + 1, len, 0)) {
+ if (len && (len != 4 || strNE(PL_tokenbuf+1, "CORE"))
+ && !keyword(PL_tokenbuf + 1, len, 0)) {
d = SKIPSPACE1(d);
if (*d == '(') {
force_ident_maybe_lex('&');
LOP(OP_PIPE_OP,XTERM);
case KEY_q:
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
- COPLINE_SET_FROM_MULTI_END;
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
if (!s)
missingterm(NULL);
+ COPLINE_SET_FROM_MULTI_END;
pl_yylval.ival = OP_CONST;
TERM(sublex_start());
case KEY_qw: {
OP *words = NULL;
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
- COPLINE_SET_FROM_MULTI_END;
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
if (!s)
missingterm(NULL);
+ COPLINE_SET_FROM_MULTI_END;
PL_expect = XOPERATOR;
if (SvCUR(PL_lex_stuff)) {
int warned_comma = !ckWARN(WARN_QW);
}
case KEY_qq:
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
if (!s)
missingterm(NULL);
pl_yylval.ival = OP_STRINGIFY;
TERM(sublex_start());
case KEY_qx:
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
if (!s)
missingterm(NULL);
pl_yylval.ival = OP_BACKTICK;
gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf),
GV_ADD | (UTF ? SVf_UTF8 : 0));
else if (*s == '<')
- yyerror("<> should be quotes");
+ yyerror("<> at require-statement should be quotes");
}
if (orig_keyword == KEY_require) {
orig_keyword = 0;
}
/* Look for a prototype */
- if (*s == '(') {
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ if (*s == '(' && !FEATURE_SIGNATURES_IS_ENABLED) {
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
COPLINE_SET_FROM_MULTI_END;
if (!s)
Perl_croak(aTHX_ "Prototype not terminated");
if (*s == ':' && s[1] != ':')
PL_expect = attrful;
- else if (*s != '{' && key == KEY_sub) {
+ else if ((*s != '{' && *s != '(') && key == KEY_sub) {
if (!have_name)
Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
else if (*s != ';' && *s != '}')
tmp = allocmy(PL_tokenbuf, tokenbuf_len, UTF ? SVf_UTF8 : 0);
}
else {
- if (has_colon)
+ if (has_colon) {
+ /* PL_no_myglob is constant */
+ GCC_DIAG_IGNORE(-Wformat-nonliteral);
yyerror_pv(Perl_form(aTHX_ PL_no_myglob,
PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf),
UTF ? SVf_UTF8 : 0);
+ GCC_DIAG_RESTORE;
+ }
pl_yylval.opval = newOP(OP_PADANY, 0);
pl_yylval.opval->op_targ = allocmy(PL_tokenbuf, tokenbuf_len,
newSVpvs(":full"),
newSVpvs(":short"),
NULL);
- SPAGAIN;
+ assert(sp == PL_stack_sp);
table = GvHV(PL_hintgv);
if (table
&& (PL_hints & HINT_LOCALIZE_HH)
yyerror(Perl_form(aTHX_ "Regexp modifiers \"/%c\" and \"/%c\" are mutually exclusive", *charset, c));
}
else if (c == 'a') {
+ /* diag_listed_as: Regexp modifier "/%c" may appear a maximum of twice */
yyerror("Regexp modifier \"/a\" may appear a maximum of twice");
}
else {
PERL_ARGS_ASSERT_SCAN_PAT;
s = scan_str(start,!!PL_madskills,FALSE, (PL_in_eval & EVAL_RE_REPARSING),
- TRUE /* look for escaped bracketed metas */ );
+ TRUE /* look for escaped bracketed metas */, NULL);
if (!s) {
const char * const delimiter = skipspace(start);
#ifdef PERL_MAD
char *modstart;
#endif
+ char *t;
PERL_ARGS_ASSERT_SCAN_SUBST;
pl_yylval.ival = OP_NULL;
s = scan_str(start,!!PL_madskills,FALSE,FALSE,
- TRUE /* look for escaped bracketed metas */ );
+ TRUE /* look for escaped bracketed metas */, &t);
if (!s)
Perl_croak(aTHX_ "Substitution pattern not terminated");
- if (s[-1] == PL_multi_open)
- s--;
+ s = t;
#ifdef PERL_MAD
if (PL_madskills) {
CURMAD('q', PL_thisopen);
first_start = PL_multi_start;
first_line = CopLINE(PL_curcop);
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
if (!s) {
if (PL_lex_stuff) {
SvREFCNT_dec(PL_lex_stuff);
#ifdef PERL_MAD
char *modstart;
#endif
+ char *t;
PERL_ARGS_ASSERT_SCAN_TRANS;
pl_yylval.ival = OP_NULL;
- s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(start,!!PL_madskills,FALSE,FALSE,FALSE,&t);
if (!s)
Perl_croak(aTHX_ "Transliteration pattern not terminated");
- if (s[-1] == PL_multi_open)
- s--;
+ s = t;
#ifdef PERL_MAD
if (PL_madskills) {
CURMAD('q', PL_thisopen);
}
#endif
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
if (!s) {
if (PL_lex_stuff) {
SvREFCNT_dec(PL_lex_stuff);
if (d - PL_tokenbuf != len) {
pl_yylval.ival = OP_GLOB;
- s = scan_str(start,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(start,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
if (!s)
Perl_croak(aTHX_ "Glob not terminated");
return s;
Copy("ARGV",d,5,char);
/* Check whether readline() is overriden */
- gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
if ((gv_readline = gv_override("readline",8)))
readline_overriden = TRUE;
deprecate_escaped_meta issue a deprecation warning for cer-
tain paired metacharacters that appear
escaped within it
+ delimp if non-null, this is set to the position of
+ the closing delimiter, or just after it if
+ the closing and opening delimiters differ
+ (i.e., the opening delimiter of a substitu-
+ tion replacement)
returns: position to continue reading from buffer
side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
updates the read buffer.
STATIC char *
S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims, int re_reparse,
- bool deprecate_escaped_meta
+ bool deprecate_escaped_meta, char **delimp
)
{
dVAR;
PL_sublex_info.repl = sv;
else
PL_lex_stuff = sv;
+ if (delimp) *delimp = PL_multi_open == PL_multi_close ? s-termlen : s;
return s;
}
case '8': case '9':
if (shift == 3)
yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
- /* FALL THROUGH */
+ /* FALLTHROUGH */
/* octal digits */
case '2': case '3': case '4':
case '5': case '6': case '7':
if (shift == 1)
yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
- /* FALL THROUGH */
+ /* FALLTHROUGH */
case '0': case '1':
b = *s++ & 15; /* ASCII digit -> value of digit */
floatit = TRUE;
}
if (floatit) {
+ STORE_NUMERIC_LOCAL_SET_STANDARD();
/* terminate the string */
*d = '\0';
nv = Atof(PL_tokenbuf);
+ RESTORE_NUMERIC_LOCAL();
sv = newSVnv(nv);
}
if (SvCUR(stuff)) {
PL_expect = XSTATE;
if (needargs) {
+ const char *s2 = s;
+ while (*s2 == '\r' || *s2 == ' ' || *s2 == '\t' || *s2 == '\f'
+ || *s2 == 013)
+ s2++;
+ if (*s2 == '{') {
+ start_force(PL_curforce);
+ PL_expect = XTERMBLOCK;
+ NEXTVAL_NEXTTOKE.ival = 0;
+ force_next(DO);
+ }
start_force(PL_curforce);
NEXTVAL_NEXTTOKE.ival = 0;
force_next(FORMLBRACK);
#endif
}
}
+ break;
default:
if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
return stmtseqop;
}
+#define lex_token_boundary() S_lex_token_boundary(aTHX)
+static void
+S_lex_token_boundary(pTHX)
+{
+ PL_oldoldbufptr = PL_oldbufptr;
+ PL_oldbufptr = PL_bufptr;
+}
+
+#define parse_opt_lexvar() S_parse_opt_lexvar(aTHX)
+static OP *
+S_parse_opt_lexvar(pTHX)
+{
+ I32 sigil, c;
+ char *s, *d;
+ OP *var;
+ lex_token_boundary();
+ sigil = lex_read_unichar(0);
+ if (lex_peek_unichar(0) == '#') {
+ qerror(Perl_mess(aTHX_ "Parse error"));
+ return NULL;
+ }
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ if (c == -1 || !(UTF ? isIDFIRST_uni(c) : isIDFIRST_A(c)))
+ return NULL;
+ s = PL_bufptr;
+ d = PL_tokenbuf + 1;
+ PL_tokenbuf[0] = (char)sigil;
+ parse_ident(&s, &d, PL_tokenbuf + sizeof(PL_tokenbuf) - 1, 0, cBOOL(UTF));
+ PL_bufptr = s;
+ if (d == PL_tokenbuf+1)
+ return NULL;
+ *d = 0;
+ var = newOP(sigil == '$' ? OP_PADSV : sigil == '@' ? OP_PADAV : OP_PADHV,
+ OPf_MOD | (OPpLVAL_INTRO<<8));
+ var->op_targ = allocmy(PL_tokenbuf, d - PL_tokenbuf, UTF ? SVf_UTF8 : 0);
+ return var;
+}
+
+OP *
+Perl_parse_subsignature(pTHX)
+{
+ I32 c;
+ int prev_type = 0, pos = 0, min_arity = 0, max_arity = 0;
+ OP *initops = NULL;
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ while (c != /*(*/')') {
+ switch (c) {
+ case '$': {
+ OP *var, *expr;
+ if (prev_type == 2)
+ qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
+ var = parse_opt_lexvar();
+ expr = var ?
+ newBINOP(OP_AELEM, 0,
+ ref(newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv)),
+ OP_RV2AV),
+ newSVOP(OP_CONST, 0, newSViv(pos))) :
+ NULL;
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ if (c == '=') {
+ lex_token_boundary();
+ lex_read_unichar(0);
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ if (c == ',' || c == /*(*/')') {
+ if (var)
+ qerror(Perl_mess(aTHX_ "Optional parameter "
+ "lacks default expression"));
+ } else {
+ OP *defexpr = parse_termexpr(0);
+ if (defexpr->op_type == OP_UNDEF &&
+ !(defexpr->op_flags & OPf_KIDS)) {
+ op_free(defexpr);
+ } else {
+ OP *ifop =
+ newBINOP(OP_GE, 0,
+ scalar(newUNOP(OP_RV2AV, 0,
+ newGVOP(OP_GV, 0, PL_defgv))),
+ newSVOP(OP_CONST, 0, newSViv(pos+1)));
+ expr = var ?
+ newCONDOP(0, ifop, expr, defexpr) :
+ newLOGOP(OP_OR, 0, ifop, defexpr);
+ }
+ }
+ prev_type = 1;
+ } else {
+ if (prev_type == 1)
+ qerror(Perl_mess(aTHX_ "Mandatory parameter "
+ "follows optional parameter"));
+ prev_type = 0;
+ min_arity = pos + 1;
+ }
+ if (var) expr = newASSIGNOP(OPf_STACKED, var, 0, expr);
+ if (expr)
+ initops = op_append_list(OP_LINESEQ, initops,
+ newSTATEOP(0, NULL, expr));
+ max_arity = ++pos;
+ } break;
+ case '@':
+ case '%': {
+ OP *var;
+ if (prev_type == 2)
+ qerror(Perl_mess(aTHX_ "Slurpy parameter not last"));
+ var = parse_opt_lexvar();
+ if (c == '%') {
+ OP *chkop = newLOGOP((pos & 1) ? OP_OR : OP_AND, 0,
+ newBINOP(OP_BIT_AND, 0,
+ scalar(newUNOP(OP_RV2AV, 0,
+ newGVOP(OP_GV, 0, PL_defgv))),
+ newSVOP(OP_CONST, 0, newSViv(1))),
+ newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
+ newSVOP(OP_CONST, 0,
+ newSVpvs("Odd name/value argument "
+ "for subroutine"))));
+ if (pos != min_arity)
+ chkop = newLOGOP(OP_AND, 0,
+ newBINOP(OP_GT, 0,
+ scalar(newUNOP(OP_RV2AV, 0,
+ newGVOP(OP_GV, 0, PL_defgv))),
+ newSVOP(OP_CONST, 0, newSViv(pos))),
+ chkop);
+ initops = op_append_list(OP_LINESEQ,
+ newSTATEOP(0, NULL, chkop),
+ initops);
+ }
+ if (var) {
+ OP *slice = pos ?
+ op_prepend_elem(OP_ASLICE,
+ newOP(OP_PUSHMARK, 0),
+ newLISTOP(OP_ASLICE, 0,
+ list(newRANGE(0,
+ newSVOP(OP_CONST, 0, newSViv(pos)),
+ newUNOP(OP_AV2ARYLEN, 0,
+ ref(newUNOP(OP_RV2AV, 0,
+ newGVOP(OP_GV, 0, PL_defgv)),
+ OP_AV2ARYLEN)))),
+ ref(newUNOP(OP_RV2AV, 0,
+ newGVOP(OP_GV, 0, PL_defgv)),
+ OP_ASLICE))) :
+ newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, PL_defgv));
+ initops = op_append_list(OP_LINESEQ, initops,
+ newSTATEOP(0, NULL,
+ newASSIGNOP(OPf_STACKED, var, 0, slice)));
+ }
+ prev_type = 2;
+ max_arity = -1;
+ } break;
+ default:
+ parse_error:
+ qerror(Perl_mess(aTHX_ "Parse error"));
+ return NULL;
+ }
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ switch (c) {
+ case /*(*/')': break;
+ case ',':
+ do {
+ lex_token_boundary();
+ lex_read_unichar(0);
+ lex_read_space(0);
+ c = lex_peek_unichar(0);
+ } while (c == ',');
+ break;
+ default:
+ goto parse_error;
+ }
+ }
+ if (min_arity != 0) {
+ initops = op_append_list(OP_LINESEQ,
+ newSTATEOP(0, NULL,
+ newLOGOP(OP_OR, 0,
+ newBINOP(OP_GE, 0,
+ scalar(newUNOP(OP_RV2AV, 0,
+ newGVOP(OP_GV, 0, PL_defgv))),
+ newSVOP(OP_CONST, 0, newSViv(min_arity))),
+ newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
+ newSVOP(OP_CONST, 0,
+ newSVpvs("Too few arguments for subroutine"))))),
+ initops);
+ }
+ if (max_arity != -1) {
+ initops = op_append_list(OP_LINESEQ,
+ newSTATEOP(0, NULL,
+ newLOGOP(OP_OR, 0,
+ newBINOP(OP_LE, 0,
+ scalar(newUNOP(OP_RV2AV, 0,
+ newGVOP(OP_GV, 0, PL_defgv))),
+ newSVOP(OP_CONST, 0, newSViv(max_arity))),
+ newLISTOP(OP_DIE, 0, newOP(OP_PUSHMARK, 0),
+ newSVOP(OP_CONST, 0,
+ newSVpvs("Too many arguments for subroutine"))))),
+ initops);
+ }
+ return initops;
+}
+
/*
* Local variables:
* c-indentation-style: bsd
https://perl5.git.perl.org / perl5.git / blobdiff