X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=ad8dfbe9d008ab01b3d7f212703a6349965b7259;hb=248e23d9b695ef46108b0307a3e93bc148355a94;hp=00dbf7fc47cfca475d3a1e93e2baf0730de8e30e;hpb=3bd495df69b982704c59fc1ecbed71e5112e7da0;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/toke.c b/toke.c
index 00dbf7f..ad8dfbe 100644
--- a/toke.c
+++ b/toke.c
@@ -50,6 +50,7 @@ static int uni _((I32 f, char *s));
 #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 */
@@ -181,7 +182,7 @@ missingterm(char *s)
     char q;
     if (s) {
 	char *nl = strrchr(s,'\n');
-	if (nl) 
+	if (nl)
 	    *nl = '\0';
     }
     else if (multi_close < 32 || multi_close == 127) {
@@ -403,8 +404,6 @@ skipspace(register char *s)
 		PerlIO_clearerr(rsfp);
 	    else
 		(void)PerlIO_close(rsfp);
-	    if (e_fp == rsfp)
-		e_fp = Nullfp;
 	    rsfp = Nullfp;
 	    return s;
 	}
@@ -545,7 +544,7 @@ force_ident(register char *s, int kind)
 	    /* 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 :
@@ -588,20 +587,23 @@ tokeq(SV *sv)
     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] == '\\'))
@@ -611,7 +613,9 @@ tokeq(SV *sv)
     }
     *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;
 }
 
@@ -627,10 +631,19 @@ sublex_start(void)
     }
     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;
     }
@@ -758,6 +771,12 @@ sublex_done(void)
   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
@@ -825,17 +844,11 @@ scan_const(char *start)
     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) */
@@ -1022,10 +1035,18 @@ scan_const(char *start)
 	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;
 }
@@ -1068,7 +1089,7 @@ intuit_more(register char *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];
 
@@ -1134,6 +1155,8 @@ intuit_more(register char *s)
 		    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) &&
@@ -1347,7 +1370,7 @@ filter_read(int idx, SV *buf_sv, int maxlen)
     /* 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 *
@@ -1499,7 +1522,7 @@ yylex(void)
 	/* 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));
@@ -1657,6 +1680,8 @@ yylex(void)
 	    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;
 	}
@@ -1783,8 +1808,6 @@ yylex(void)
 			PerlIO_clearerr(rsfp);
 		    else
 			(void)PerlIO_close(rsfp);
-		    if (e_fp == rsfp)
-			e_fp = Nullfp;
 		    rsfp = Nullfp;
 		}
 		if (!in_eval && (minus_n || minus_p)) {
@@ -2223,13 +2246,8 @@ yylex(void)
 		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
@@ -2803,14 +2821,28 @@ yylex(void)
 	}
 
 	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 */
@@ -2818,8 +2850,13 @@ yylex(void)
 	    {
 		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));
 	    }
 	}
 
@@ -2838,7 +2875,8 @@ yylex(void)
 		    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;
 		}
 
@@ -2899,8 +2937,11 @@ yylex(void)
 		    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 == '(';
 
@@ -2981,16 +3022,17 @@ yylex(void)
 		    /* 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);
@@ -4376,6 +4418,8 @@ keyword(register char *d, I32 len)
 	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;
@@ -4689,6 +4733,75 @@ checkcomma(register char *s, char *name, char *what)
     }
 }
 
+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)
 {
@@ -4913,13 +5026,15 @@ scan_subst(char *start)
     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) {
@@ -5047,7 +5162,7 @@ scan_heredoc(register char *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;
@@ -5075,7 +5190,7 @@ scan_heredoc(register char *s)
 	}
 	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);
@@ -5305,8 +5420,8 @@ scan_str(char *start)
     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 */
@@ -5537,7 +5652,8 @@ scan_num(char *start)
 
 		  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;
@@ -5553,6 +5669,8 @@ scan_num(char *start)
 	  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;
 
@@ -5654,6 +5772,9 @@ scan_num(char *start)
 	    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;
     }