* "It all comes from here, the stench and the peril." --Frodo
*/
+#define TMP_CRLF_PATCH
+
#include "EXTERN.h"
#include "perl.h"
static char *scan_ident _((char *s, char *send, char *dest, STRLEN destlen,
I32 ck_uni));
static char *scan_inputsymbol _((char *start));
-static char *scan_pat _((char *start));
+static char *scan_pat _((char *start, I32 type));
static char *scan_str _((char *start));
static char *scan_subst _((char *start));
static char *scan_trans _((char *start));
#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;
}
/* 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;
}
curcop->cop_line = multi_start;
lex_inwhat = sublex_info.sub_inwhat;
- if (lex_inwhat == OP_MATCH || lex_inwhat == OP_SUBST)
+ if (lex_inwhat == OP_MATCH || lex_inwhat == OP_QR || lex_inwhat == OP_SUBST)
lex_inpat = sublex_info.sub_op;
else
lex_inpat = Nullop;
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) */
*d++ = *s++;
} else if (s[2] == '{') { /* This should march regcomp.c */
I32 count = 1;
- char *pregparse = s + 3;
+ char *regparse = s + 3;
char c;
- while (count && (c = *pregparse)) {
- if (c == '\\' && pregparse[1])
- pregparse++;
+ while (count && (c = *regparse)) {
+ if (c == '\\' && regparse[1])
+ regparse++;
else if (c == '{')
count++;
else if (c == '}')
count--;
- pregparse++;
+ regparse++;
}
- if (*pregparse == ')')
- pregparse++;
+ if (*regparse == ')')
+ regparse++;
else
yyerror("Sequence (?{...}) not terminated or not {}-balanced");
- while (s < pregparse && *s != ')')
+ while (s < regparse && *s != ')')
*d++ = *s++;
}
}
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 *
/* 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;
}
PerlIO_clearerr(rsfp);
else
(void)PerlIO_close(rsfp);
- if (e_fp == rsfp)
- e_fp = Nullfp;
rsfp = Nullfp;
}
if (!in_eval && (minus_n || minus_p)) {
}
goto retry;
case '\r':
-#ifndef WIN32CHEAT
+#ifndef TMP_CRLF_PATCH
warn("Illegal character \\%03o (carriage return)", '\r');
croak(
"(Maybe you didn't strip carriage returns after a network transfer?)\n");
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
&& (*last_uni != 's' || s - last_uni < 5
|| memNE(last_uni, "study", 5) || isALNUM(last_uni[5])))
check_uni();
- s = scan_pat(s);
+ s = scan_pat(s,OP_MATCH);
TERM(sublex_start());
}
tmp = *s++;
tmp = (len == 1 && strchr("msyq", tokenbuf[0]) ||
len == 2 && ((tokenbuf[0] == 't' && tokenbuf[1] == 'r') ||
(tokenbuf[0] == 'q' &&
- strchr("qwx", tokenbuf[1]))));
+ strchr("qwxr", tokenbuf[1]))));
/* x::* is just a word, unless x is "CORE" */
if (!tmp && *s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE"))
}
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("Ambiguous call resolved as CORE::%s(), "
+ "qualify as such or use &", GvENAME(hgv));
}
}
s = scan_word(s, tokenbuf + len, sizeof tokenbuf - len,
TRUE, &morelen);
if (!morelen)
- croak("Bad name after %s::", tokenbuf);
+ croak("Bad name after %s%s", tokenbuf,
+ *s == '\'' ? "'" : "::");
len += morelen;
}
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);
UNI(OP_LSTAT);
case KEY_m:
- s = scan_pat(s);
+ s = scan_pat(s,OP_MATCH);
TERM(sublex_start());
case KEY_map:
SvIVX(lex_stuff) = 0; /* qq'$foo' should intepolate */
TERM(sublex_start());
+ case KEY_qr:
+ s = scan_pat(s,OP_QR);
+ TERM(sublex_start());
+
case KEY_qx:
s = scan_str(s);
if (!s)
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;
case 'q':
if (len <= 2) {
if (strEQ(d,"q")) return KEY_q;
+ if (strEQ(d,"qr")) return KEY_qr;
if (strEQ(d,"qq")) return KEY_qq;
if (strEQ(d,"qw")) return KEY_qw;
if (strEQ(d,"qx")) return KEY_qx;
}
}
+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(PERLSI_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)
{
}
STATIC char *
-scan_pat(char *start)
+scan_pat(char *start, I32 type)
{
PMOP *pm;
char *s;
croak("Search pattern not terminated");
}
- pm = (PMOP*)newPMOP(OP_MATCH, 0);
+ pm = (PMOP*)newPMOP(type, 0);
if (multi_open == '?')
pm->op_pmflags |= PMf_ONCE;
- while (*s && strchr("iogcmsx", *s))
- pmflag(&pm->op_pmflags,*s++);
+ if(type == OP_QR) {
+ while (*s && strchr("iomsx", *s))
+ pmflag(&pm->op_pmflags,*s++);
+ }
+ else {
+ while (*s && strchr("iogcmsx", *s))
+ pmflag(&pm->op_pmflags,*s++);
+ }
pm->op_pmpermflags = pm->op_pmflags;
lex_op = (OP*)pm;
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("iogcmsx", *s))
pmflag(&pm->op_pmflags,*s++);
+ else
+ break;
}
if (es) {
*d++ = '\n';
*d = '\0';
len = d - tokenbuf;
+#ifdef TMP_CRLF_PATCH
+ d = strchr(s, '\r');
+ if (d) {
+ char *olds = s;
+ s = d;
+ while (s < bufend) {
+ if (*s == '\r') {
+ *d++ = '\n';
+ if (*++s == '\n')
+ s++;
+ }
+ else if (*s == '\n' && s[1] == '\r') { /* \015\013 on a mac? */
+ *d++ = *s++;
+ s++;
+ }
+ else
+ *d++ = *s++;
+ }
+ *d = '\0';
+ bufend = d;
+ SvCUR_set(linestr, bufend - SvPVX(linestr));
+ s = olds;
+ }
+#endif
d = "\n";
if (outer || !(d=ninstr(s,bufend,d,d+1)))
herewas = newSVpv(s,bufend-s);
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);
missingterm(tokenbuf);
}
curcop->cop_line++;
+ bufend = SvPVX(linestr) + SvCUR(linestr);
+#ifdef TMP_CRLF_PATCH
+ if (bufend - linestart >= 2) {
+ if (bufend[-2] == '\r' || bufend[-2] == '\n') {
+ bufend[-2] = '\n';
+ bufend--;
+ SvCUR_set(linestr, bufend - SvPVX(linestr));
+ }
+ else if (bufend[-1] == '\r')
+ bufend[-1] = '\n';
+ }
+ else if (bufend - linestart == 1 && bufend[-1] == '\r')
+ bufend[-1] = '\n';
+#endif
if (PERLDB_LINE && curstash != debstash) {
SV *sv = NEWSV(88,0);
av_store(GvAV(curcop->cop_filegv),
(I32)curcop->cop_line,sv);
}
- bufend = SvPVX(linestr) + SvCUR(linestr);
if (*s == term && memEQ(s,tokenbuf,len)) {
s = bufend - 1;
*s = ' ';
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 */
if (s < bufend) break; /* handle case where we are done yet :-) */
+#ifdef TMP_CRLF_PATCH
+ if (to - SvPVX(sv) >= 2) {
+ if (to[-2] == '\r' || to[-2] == '\n') {
+ to[-2] = '\n';
+ to--;
+ SvCUR_set(sv, to - SvPVX(sv));
+ }
+ else if (to[-1] == '\r')
+ to[-1] = '\n';
+ }
+ else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
+ to[-1] = '\n';
+#endif
+
/* if we're out of file, or a read fails, bail and reset the current
line marker so we can report where the unterminated string began
*/
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;
}
https://perl5.git.perl.org / perl5.git / blobdiff