#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 */
char q;
if (s) {
char *nl = strrchr(s,'\n');
- if (nl)
+ if (nl)
*nl = '\0';
}
else if (multi_close < 32 || multi_close == 127) {
PerlIO_clearerr(rsfp);
else
(void)PerlIO_close(rsfp);
- if (e_fp == rsfp)
- e_fp = Nullfp;
rsfp = Nullfp;
return s;
}
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;
}
processing a pattern (lex_inpat is true), a transliteration
(lex_inwhat & OP_TRANS is true), or a double-quoted string.
+ Returns a pointer to the character scanned up to. Iff this is
+ advanced from the start pointer supplied (ie if anything was
+ successfully parsed), will leave an OP for the substring scanned
+ in yylval. Caller must intuit reason for not parsing further
+ by looking at the next characters herself.
+
In patterns:
backslashes:
double-quoted style: \r and \n
bool dorange = FALSE; /* are we in a translit range? */
I32 len; /* ? */
- /*
- leave is the set of acceptably-backslashed characters.
-
- I do *not* understand why there's the double hook here.
- */
+ /* leaveit is the set of acceptably-backslashed characters */
char *leaveit =
lex_inpat
- ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxc0123456789[{]} \t\n\r\f\v#"
- : (lex_inwhat & OP_TRANS)
- ? ""
- : "";
+ ? "\\.^$@AGZdDwWsSbB+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
+ : "";
while (s < send || dorange) {
/* get transliterations out of the way (they're most literal) */
Renew(SvPVX(sv), SvLEN(sv), char);
}
- /* ??? */
- if (s > bufptr)
+ /* return the substring (via yylval) only if we parsed anything */
+ 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;
}
else {
int weight = 2; /* let's weigh the evidence */
char seen[256];
- unsigned char un_char = 0, last_un_char;
+ unsigned char un_char = 255, last_un_char;
char *send = strchr(s,']');
char tmpbuf[sizeof tokenbuf * 4];
weight += 30;
if (strchr("zZ79~",s[1]))
weight += 30;
+ if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
+ weight -= 5; /* cope with negative subscript */
break;
default:
if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
/* 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)(idx, buf_sv, maxlen);
+ return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
}
STATIC char *
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;
}
PerlIO_clearerr(rsfp);
else
(void)PerlIO_close(rsfp);
- if (e_fp == rsfp)
- e_fp = Nullfp;
rsfp = Nullfp;
}
if (!in_eval && (minus_n || minus_p)) {
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
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);
}
}
+STATIC SV *
+new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
+{
+ HV *table = perl_get_hv("\10", FALSE); /* ^H */
+ dTHR;
+ dSP;
+ 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, 3);
+ 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("iogcmsx", *s))
+ while (*s && strchr("iogcmstx", *s))
pmflag(&pm->op_pmflags,*s++);
pm->op_pmpermflags = pm->op_pmflags;
multi_start = first_start; /* so whole substitution is taken together */
pm = (PMOP*)newPMOP(OP_SUBST, 0);
- while (*s && strchr("iogcmsex", *s)) {
+ while (*s) {
if (*s == 'e') {
s++;
es++;
}
- else
+ else if (strchr("iogcmstx", *s))
pmflag(&pm->op_pmflags,*s++);
+ else
+ break;
}
if (es) {
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;
}
sv_setpvn(tmpstr,d+1,s-d);
s += len - 1;
- curcop->cop_line++; /* the preceding stmt passes a newline */
+ curcop->cop_line++; /* the preceding stmt passes a newline */
sv_catpvn(herewas,s,bufend-s);
sv_setsv(linestr,herewas);
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;
}