#endif
static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append));
static void restore_rsfp _((void *f));
+static SV *new_constant _((char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type));
static void restore_expect _((void *e));
static void restore_lex_expect _((void *e));
#endif /* PERL_OBJECT */
/* XXX see note in pp_entereval() for why we forgo typo
warnings if the symbol must be introduced in an eval.
GSAR 96-10-12 */
- gv_fetchpv(s, in_eval ? (GV_ADDMULTI | 8) : TRUE,
+ gv_fetchpv(s, in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
kind == '$' ? SVt_PV :
kind == '@' ? SVt_PVAV :
kind == '%' ? SVt_PVHV :
register char *s;
register char *send;
register char *d;
- STRLEN len;
+ STRLEN len = 0;
+ SV *pv = sv;
if (!SvLEN(sv))
- return sv;
+ goto finish;
s = SvPV_force(sv, len);
if (SvIVX(sv) == -1)
- return sv;
+ goto finish;
send = s + len;
while (s < send && *s != '\\')
s++;
if (s == send)
- return sv;
+ goto finish;
d = s;
+ if ( hints & HINT_NEW_STRING )
+ pv = sv_2mortal(newSVpv(SvPVX(pv), len));
while (s < send) {
if (*s == '\\') {
if (s + 1 < send && (s[1] == '\\'))
}
*d = '\0';
SvCUR_set(sv, d - SvPVX(sv));
-
+ finish:
+ if ( hints & HINT_NEW_STRING )
+ return new_constant(NULL, 0, "q", sv, pv, "q");
return sv;
}
}
if (op_type == OP_CONST || op_type == OP_READLINE) {
SV *sv = tokeq(lex_stuff);
- STRLEN len;
- char *p = SvPV(sv, len);
- yylval.opval = (OP*)newSVOP(op_type, 0, newSVpv(p, len));
- SvREFCNT_dec(sv);
+
+ if (SvTYPE(sv) == SVt_PVIV) {
+ /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
+ STRLEN len;
+ char *p;
+ SV *nsv;
+
+ p = SvPV(sv, len);
+ nsv = newSVpv(p, len);
+ SvREFCNT_dec(sv);
+ sv = nsv;
+ }
+ yylval.opval = (OP*)newSVOP(op_type, 0, sv);
lex_stuff = Nullsv;
return THING;
}
/* leaveit is the set of acceptably-backslashed characters */
char *leaveit =
lex_inpat
- ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]} \t\n\r\f\v#"
+ ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
: "";
while (s < send || dorange) {
}
/* return the substring (via yylval) only if we parsed anything */
- if (s > bufptr)
+ if (s > bufptr) {
+ if ( hints & ( lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
+ sv = new_constant(start, s - start, (lex_inpat ? "qr" : "q"),
+ sv, Nullsv,
+ ( lex_inwhat == OP_TRANS
+ ? "tr"
+ : ( (lex_inwhat == OP_SUBST && !lex_inpat)
+ ? "s"
+ : "qq")));
yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
- else
+ } else
SvREFCNT_dec(sv);
return s;
}
/* Call function. The function is expected to */
/* call "FILTER_READ(idx+1, buf_sv)" first. */
/* Return: <0:error, =0:eof, >0:not eof */
- return (*funcp)(THIS_ idx, buf_sv, maxlen);
+ return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
}
STATIC char *
/* build ops for a bareword */
yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf+1, 0));
yylval.opval->op_private = OPpCONST_ENTERED;
- gv_fetchpv(tokenbuf+1, in_eval ? (GV_ADDMULTI | 8) : TRUE,
+ gv_fetchpv(tokenbuf+1, in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
((tokenbuf[0] == '$') ? SVt_PV
: (tokenbuf[0] == '@') ? SVt_PVAV
: SVt_PVHV));
SV *sv = newSVsv(linestr);
if (!lex_inpat)
sv = tokeq(sv);
+ else if ( hints & HINT_NEW_RE )
+ sv = new_constant(NULL, 0, "qr", sv, sv, "q");
yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
s = bufend;
}
else
lex_brackstack[lex_brackets++] = XOPERATOR;
s = skipspace(s);
- if (*s == '}') {
- if (expect == XSTATE) {
- lex_brackstack[lex_brackets-1] = XSTATE;
- break;
- }
+ if (*s == '}')
OPERATOR(HASHBRACK);
- }
/* This hack serves to disambiguate a pair of curlies
* as being a block or an anon hash. Normally, expectation
* determines that, but in cases where we're not in a
}
if (tmp < 0) { /* second-class keyword? */
- if (expect != XOPERATOR && (*s != ':' || s[1] != ':') &&
- (((gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV)) &&
- GvCVu(gv) && GvIMPORTED_CV(gv)) ||
- ((gvp = (GV**)hv_fetch(globalstash,tokenbuf,len,FALSE)) &&
- (gv = *gvp) != (GV*)&sv_undef &&
- GvCVu(gv) && GvIMPORTED_CV(gv))))
- {
- tmp = 0; /* overridden by importation */
+ GV *ogv = Nullgv; /* override (winner) */
+ GV *hgv = Nullgv; /* hidden (loser) */
+ if (expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
+ CV *cv;
+ if ((gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV)) &&
+ (cv = GvCVu(gv)))
+ {
+ if (GvIMPORTED_CV(gv))
+ ogv = gv;
+ else if (! CvMETHOD(cv))
+ hgv = gv;
+ }
+ if (!ogv &&
+ (gvp = (GV**)hv_fetch(globalstash,tokenbuf,len,FALSE)) &&
+ (gv = *gvp) != (GV*)&sv_undef &&
+ GvCVu(gv) && GvIMPORTED_CV(gv))
+ {
+ ogv = gv;
+ }
+ }
+ if (ogv) {
+ tmp = 0; /* overridden by import or by GLOBAL */
}
else if (gv && !gvp
&& -tmp==KEY_lock /* XXX generalizable kludge */
{
tmp = 0; /* any sub overrides "weak" keyword */
}
- else {
- tmp = -tmp; gv = Nullgv; gvp = 0;
+ else { /* no override */
+ tmp = -tmp;
+ gv = Nullgv;
+ gvp = 0;
+ if (dowarn && hgv)
+ warn("Subroutine %s::%s hidden by keyword; use ampersand",
+ HvNAME(GvESTASH(hgv)), GvENAME(hgv));
}
}
oldoldbufptr < bufptr &&
(oldoldbufptr == last_lop || oldoldbufptr == last_uni) &&
/* NO SKIPSPACE BEFORE HERE! */
- (expect == XREF ||
- ((opargs[last_lop_op] >> OASHIFT)& 7) == OA_FILEREF) )
+ (expect == XREF
+ || ((opargs[last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
+ || (last_lop_op == OP_ENTERSUB
+ && last_proto
+ && last_proto[last_proto[0] == ';' ? 1 : 0] == '*')) )
{
bool immediate_paren = *s == '(';
/* Is there a prototype? */
if (SvPOK(cv)) {
STRLEN len;
- char *proto = SvPV((SV*)cv, len);
+ last_proto = SvPV((SV*)cv, len);
if (!len)
TERM(FUNC0SUB);
- if (strEQ(proto, "$"))
+ if (strEQ(last_proto, "$"))
OPERATOR(UNIOPSUB);
- if (*proto == '&' && *s == '{') {
+ if (*last_proto == '&' && *s == '{') {
sv_setpv(subname,"__ANON__");
PREBLOCK(LSTOPSUB);
}
- }
+ } else
+ last_proto = NULL;
nextval[nexttoke].opval = yylval.opval;
expect = XTERM;
force_next(WORD);
case 3:
if (strEQ(d,"ord")) return -KEY_ord;
if (strEQ(d,"oct")) return -KEY_oct;
+ if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
+ return 0;}
break;
case 4:
if (strEQ(d,"open")) return -KEY_open;
}
}
+STATIC SV *
+new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
+{
+ dSP;
+ HV *table = GvHV(hintgv); /* ^H */
+ BINOP myop;
+ SV *res;
+ bool oldcatch = CATCH_GET;
+ SV **cvp;
+ SV *cv, *typesv;
+ char buf[128];
+
+ if (!table) {
+ yyerror("%^H is not defined");
+ return sv;
+ }
+ cvp = hv_fetch(table, key, strlen(key), FALSE);
+ if (!cvp || !SvOK(*cvp)) {
+ sprintf(buf,"$^H{%s} is not defined", key);
+ yyerror(buf);
+ return sv;
+ }
+ sv_2mortal(sv); /* Parent created it permanently */
+ cv = *cvp;
+ if (!pv)
+ pv = sv_2mortal(newSVpv(s, len));
+ if (type)
+ typesv = sv_2mortal(newSVpv(type, 0));
+ else
+ typesv = &sv_undef;
+ CATCH_SET(TRUE);
+ Zero(&myop, 1, BINOP);
+ myop.op_last = (OP *) &myop;
+ myop.op_next = Nullop;
+ myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
+
+ PUSHSTACKi(SI_OVERLOAD);
+ ENTER;
+ SAVEOP();
+ op = (OP *) &myop;
+ if (PERLDB_SUB && curstash != debstash)
+ op->op_private |= OPpENTERSUB_DB;
+ PUTBACK;
+ pp_pushmark(ARGS);
+
+ EXTEND(sp, 4);
+ PUSHs(pv);
+ PUSHs(sv);
+ PUSHs(typesv);
+ PUSHs(cv);
+ PUTBACK;
+
+ if (op = pp_entersub(ARGS))
+ CALLRUNOPS();
+ LEAVE;
+ SPAGAIN;
+
+ res = POPs;
+ PUTBACK;
+ CATCH_SET(oldcatch);
+ POPSTACK;
+
+ if (!SvOK(res)) {
+ sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
+ yyerror(buf);
+ }
+ return SvREFCNT_inc(res);
+}
+
STATIC char *
scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
{
*pmfl |= PMf_MULTILINE;
else if (ch == 's')
*pmfl |= PMf_SINGLELINE;
- else if (ch == 't')
- *pmfl |= PMf_TAINTMEM;
else if (ch == 'x')
*pmfl |= PMf_EXTENDED;
}
pm = (PMOP*)newPMOP(OP_MATCH, 0);
if (multi_open == '?')
pm->op_pmflags |= PMf_ONCE;
- while (*s && strchr("iogcmstx", *s))
+ while (*s && strchr("iogcmsx", *s))
pmflag(&pm->op_pmflags,*s++);
pm->op_pmpermflags = pm->op_pmflags;
s++;
es++;
}
- else if (strchr("iogcmstx", *s))
+ else if (strchr("iogcmsx", *s))
pmflag(&pm->op_pmflags,*s++);
else
break;
s--, herewas = newSVpv(s,d-s);
s += SvCUR(herewas);
- tmpstr = NEWSV(87,80);
+ tmpstr = NEWSV(87,79);
sv_upgrade(tmpstr, SVt_PVIV);
if (term == '\'') {
op_type = OP_CONST;
multi_close = term;
/* create a new SV to hold the contents. 87 is leak category, I'm
- assuming. 80 is the SV's initial length. What a random number. */
- sv = NEWSV(87,80);
+ assuming. 79 is the SV's initial length. What a random number. */
+ sv = NEWSV(87,79);
sv_upgrade(sv, SVt_PVIV);
SvIVX(sv) = term;
(void)SvPOK_only(sv); /* validate pointer */
digit:
n = u << shift; /* make room for the digit */
- if (!overflowed && (n >> shift) != u) {
+ if (!overflowed && (n >> shift) != u
+ && !(hints & HINT_NEW_BINARY)) {
warn("Integer overflow in %s number",
(shift == 4) ? "hex" : "octal");
overflowed = TRUE;
out:
sv = NEWSV(92,0);
sv_setuv(sv, u);
+ if ( hints & HINT_NEW_BINARY)
+ sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
}
break;
sv_setiv(sv, tryiv);
else
sv_setnv(sv, value);
+ if ( floatit ? (hints & HINT_NEW_FLOAT) : (hints & HINT_NEW_INTEGER) )
+ sv = new_constant(tokenbuf, d - tokenbuf,
+ (floatit ? "float" : "integer"), sv, Nullsv, NULL);
break;
}
projects / p5sagit/p5-mst-13.2.git / blobdiff