PL_lex_inwhat = 0;
PL_sublex_info.sub_inwhat = 0;
PL_linestr = line;
- if (SvREADONLY(PL_linestr))
- PL_linestr = sv_2mortal(newSVsv(PL_linestr));
s = SvPV_const(PL_linestr, len);
- if (!len || s[len-1] != ';') {
- if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
- PL_linestr = sv_2mortal(newSVsv(PL_linestr));
- sv_catpvs(PL_linestr, "\n;");
+ if (SvREADONLY(PL_linestr) || !len || s[len-1] != ';') {
+ PL_linestr = sv_2mortal(len ? newSVsv(PL_linestr) : newSVpvn(s, 0));
+ if (!len || s[len-1] != ';')
+ sv_catpvs(PL_linestr, "\n;");
}
SvTEMP_off(PL_linestr);
PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
if (gvp) {
gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
- if (!isGV(gv2))
+ if (!isGV(gv2)) {
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));
+ /* 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));
+ }
}
if (tmpbuf != smallbuf) Safefree(tmpbuf);
if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
PL_expect = XTERMORDORDOR;
return THING;
}
+ 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_lex_op = NULL;
+ PL_lex_stuff = NULL;
+ return THING;
+ }
PL_sublex_info.super_state = PL_lex_state;
PL_sublex_info.sub_inwhat = op_type;
bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
#endif
- const char * const leaveit = /* set of acceptably-backslashed characters */
- (const char *)
- (PL_lex_inpat
- ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-Nnrktfeaxcz0123456789[{]} \t\n\r\f\v#"
- : "");
-
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);
if (*s == '\\' && s+1 < send) {
s++;
- /* some backslashes we leave behind */
- if (*leaveit && *s && strchr(leaveit, *s)) {
- *d++ = NATIVE_TO_NEED(has_utf8,'\\');
- *d++ = NATIVE_TO_NEED(has_utf8,*s++);
- continue;
- }
-
/* deprecate \1 in strings and substitution replacements */
if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
--s;
break;
}
+ /* skip any other backslash escapes in a pattern */
+ else if (PL_lex_inpat) {
+ *d++ = NATIVE_TO_NEED(has_utf8,'\\');
+ goto default_action;
+ }
/* if we get here, it's either a quoted -, or a digit */
switch (*s) {
return gv_stashpv(pkgname, FALSE);
}
+/*
+ * S_readpipe_override
+ * Check whether readpipe() is overriden, 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);
+ 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) != (GV*)&PL_sv_undef
+ && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
+ {
+ PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST,
+ newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
+ newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
+ }
+ else {
+ set_csh();
+ }
+}
+
#ifdef PERL_MAD
/*
* Perl_madlex
no_op("Backticks",s);
if (!s)
missingterm(NULL);
- yylval.ival = OP_BACKTICK;
- set_csh();
+ readpipe_override();
TERM(sublex_start());
case '\\':
#ifdef PERL_MAD
cv &&
#endif
- SvPOK(cv)) {
+ SvPOK(cv))
+ {
STRLEN protolen;
const char *proto = SvPV_const((SV*)cv, protolen);
if (!protolen)
TERM(FUNC0SUB);
- if (*proto == '$' && proto[1] == '\0')
+ if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
OPERATOR(UNIOPSUB);
while (*proto == ';')
proto++;
case KEY_AUTOLOAD:
case KEY_DESTROY:
case KEY_BEGIN:
+ case KEY_UNITCHECK:
case KEY_CHECK:
case KEY_INIT:
case KEY_END:
s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
missingterm(NULL);
- yylval.ival = OP_BACKTICK;
- set_csh();
+ readpipe_override();
TERM(sublex_start());
case KEY_return:
/* Look for a prototype */
if (*s == '(') {
+ char *p;
+ bool bad_proto = FALSE;
+ const bool warnsyntax = ckWARN(WARN_SYNTAX);
s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
/* strip spaces and check for bad characters */
d = SvPVX(PL_lex_stuff);
tmp = 0;
- {
- char *p;
- bool bad_proto = FALSE;
- const bool warnsyntax = ckWARN(WARN_SYNTAX);
- for (p = d; *p; ++p) {
- if (!isSPACE(*p)) {
- d[tmp++] = *p;
- if (warnsyntax && !strchr("$@%*;[]&\\", *p))
- bad_proto = TRUE;
- }
+ for (p = d; *p; ++p) {
+ if (!isSPACE(*p)) {
+ d[tmp++] = *p;
+ if (warnsyntax && !strchr("$@%*;[]&\\_", *p))
+ bad_proto = TRUE;
}
- d[tmp] = '\0';
- if (bad_proto)
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
- "Illegal character in prototype for %"SVf" : %s",
- (void*)PL_subname, d);
}
+ d[tmp] = '\0';
+ if (bad_proto)
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "Illegal character in prototype for %"SVf" : %s",
+ (void*)PL_subname, d);
SvCUR_set(PL_lex_stuff, tmp);
have_proto = TRUE;
case 'a':
if (name[2] == 'y')
{ /* say */
- return (all_keywords || FEATURE_IS_ENABLED("say") ? -KEY_say : 0);
+ return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
}
goto unknown;
goto unknown;
}
- case 9: /* 8 tokens of length 9 */
+ case 9: /* 9 tokens of length 9 */
switch (name[0])
{
+ case 'U':
+ if (name[1] == 'N' &&
+ name[2] == 'I' &&
+ name[3] == 'T' &&
+ name[4] == 'C' &&
+ name[5] == 'H' &&
+ name[6] == 'E' &&
+ name[7] == 'C' &&
+ name[8] == 'K')
+ { /* UNITCHECK */
+ return KEY_UNITCHECK;
+ }
+
+ goto unknown;
+
case 'e':
if (name[1] == 'n' &&
name[2] == 'd' &&
I32 termcode; /* terminating char. code */
U8 termstr[UTF8_MAXBYTES]; /* terminating string */
STRLEN termlen; /* length of terminating string */
- char *last = NULL; /* last position for nesting bracket */
+ int last_off = 0; /* last position for nesting bracket */
#ifdef PERL_MAD
int stuffstart;
char *tstart;
else {
const char *t;
char *w;
- if (!last)
- last = SvPVX(sv);
- for (t = w = last; t < svlast; w++, t++) {
+ for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
/* At here, all closes are "was quoted" one,
so we don't check PL_multi_close. */
if (*t == '\\') {
*w = '\0';
SvCUR_set(sv, w - SvPVX_const(sv));
}
- last = w;
+ last_off = w - SvPVX(sv);
if (--brackets <= 0)
cont = FALSE;
}
projects / p5sagit/p5-mst-13.2.git / blobdiff