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);
}
*/
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)) {
PL_lex_op = NULL;
return THING;
}
- if (op_type == OP_CONST || op_type == OP_READLINE) {
+ if (op_type == OP_CONST) {
SV *sv = tokeq(PL_lex_stuff);
if (SvTYPE(sv) == SVt_PVIV) {
}
pl_yylval.opval = (OP*)newSVOP(op_type, 0, sv);
PL_lex_stuff = NULL;
- /* Allow <FH> // "foo" */
- if (op_type == OP_READLINE)
- PL_expect = XTERMORDORDOR;
- return THING;
- }
- else if (op_type == OP_BACKTICK && PL_lex_op) {
- /* readpipe() was overridden */
- cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
- pl_yylval.opval = PL_lex_op;
- PL_lex_op = NULL;
- PL_lex_stuff = NULL;
return THING;
}
/* 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);
SvTYPE(rv) == SVt_PVCV) && ((stash = CvSTASH(rv)) != NULL))
{
const char * const name = HvNAME(stash);
- if strEQ(name, "_charnames") {
+ if (HvNAMELEN(stash) == sizeof("_charnames")-1
+ && strEQ(name, "_charnames")) {
return res;
}
}
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;
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;
}
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 != '[')
return gv_stashpvn(pkgname, len, UTF ? SVf_UTF8 : 0);
}
-/*
- * S_readpipe_override
- * Check whether readpipe() is overridden, and generates the appropriate
- * optree, provided sublex_start() is called afterwards.
- */
-STATIC void
-S_readpipe_override(pTHX)
-{
- GV **gvp;
- GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
- pl_yylval.ival = OP_BACKTICK;
- if ((gv_readpipe
- && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
- ||
- ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
- && (gv_readpipe = *gvp) && (
- isGV_with_GP(gv_readpipe)
- ? GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)
- : SvPCS_IMPORTED(gv_readpipe)
- && (gv_init(gv_readpipe, PL_globalstash, "readpipe",
- 8, 0), 1)
- )))
- {
- COPLINE_SET_FROM_MULTI_END;
- PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
- op_append_elem(OP_LIST,
- newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
- newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
- }
-}
-
#ifdef PERL_MAD
/*
* Perl_madlex
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] == '{'))
))
if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
if (*s == '[')
PL_tokenbuf[0] = '@';
-
- /* Warn about % where they meant $. */
- if (*s == '[' || *s == '{') {
- if (ckWARN(WARN_SYNTAX)) {
- S_check_scalar_slice(aTHX_ s);
- }
- }
}
PL_expect = XOPERATOR;
force_ident_maybe_lex('%');
}
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;
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] = '@';
TERM(THING);
case '\'':
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
COPLINE_SET_FROM_MULTI_END;
DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
if (PL_expect == XOPERATOR) {
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 (!s)
missingterm(NULL);
- readpipe_override();
+ pl_yylval.ival = OP_BACKTICK;
TERM(sublex_start());
case '\\':
anydelim = word_takes_any_delimeter(PL_tokenbuf, len);
/* x::* is just a word, unless x is "CORE" */
- if (!anydelim && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
+ if (!anydelim && *s == ':' && s[1] == ':') {
+ if (strEQ(PL_tokenbuf, "CORE")) goto case_KEY_CORE;
goto just_a_word;
+ }
d = s;
while (d < PL_bufend && isSPACE(*d))
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))
}
if (!ogv &&
(gvp = (GV**)hv_fetch(PL_globalstash, PL_tokenbuf,
- UTF ? -(I32)len : (I32)len, FALSE)) &&
- (gv = *gvp) && isGV_with_GP(gv) &&
- GvCVu(gv) && GvIMPORTED_CV(gv))
+ len, FALSE)) &&
+ (gv = *gvp) && (
+ isGV_with_GP(gv)
+ ? GvCVu(gv) && GvIMPORTED_CV(gv)
+ : SvPCS_IMPORTED(gv)
+ && (gv_init(gv, PL_globalstash, PL_tokenbuf,
+ len, 0), 1)
+ ))
{
ogv = gv;
}
}
gv = NULL;
gvp = 0;
- if (hgv && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
+ if (hgv && tmp != KEY_x) /* never ambiguous */
Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
"Ambiguous call resolved as CORE::%s(), "
"qualify as such or use &",
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);
}
goto just_a_word;
- case KEY_CORE:
- if (*s == ':' && s[1] == ':') {
+ case_KEY_CORE:
+ {
STRLEN olen = len;
d = s;
s += 2;
orig_keyword = tmp;
goto reserved_word;
}
- goto just_a_word;
case KEY_abs:
UNI(OP_ABS);
*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('&');
case KEY_glob:
LOP(
- orig_keyword==KEY_glob ? (orig_keyword=0, -OP_GLOB) : OP_GLOB,
+ orig_keyword==KEY_glob ? -OP_GLOB : OP_GLOB,
XTERM
);
LOP(OP_PIPE_OP,XTERM);
case KEY_q:
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
COPLINE_SET_FROM_MULTI_END;
if (!s)
missingterm(NULL);
case KEY_qw: {
OP *words = NULL;
- s = scan_str(s,!!PL_madskills,FALSE,FALSE, FALSE);
+ s = scan_str(s,!!PL_madskills,FALSE,FALSE,FALSE,NULL);
COPLINE_SET_FROM_MULTI_END;
if (!s)
missingterm(NULL);
}
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);
- readpipe_override();
+ pl_yylval.ival = OP_BACKTICK;
TERM(sublex_start());
case KEY_return:
}
/* 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;
else {
bool readline_overriden = FALSE;
GV *gv_readline;
- GV **gvp;
/* we're in a filehandle read situation */
d = PL_tokenbuf;
/* Check whether readline() is overriden */
gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
- if ((gv_readline
- && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
- ||
- ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
- && (gv_readline = *gvp) && isGV_with_GP(gv_readline)
- && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
+ if ((gv_readline = gv_override("readline",8)))
readline_overriden = TRUE;
/* if <$fh>, create the ops to turn the variable into a
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;
}
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);
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