X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=8d8ac54eebf5b65686a18c5eb8ec2a7500e36989;hb=30ef33217aeee51ee47b2433e9384b011646254a;hp=87c94c1cf38d2f6e92e3ac83746384b42b2cc84d;hpb=9ede5bc8744780ab88b609ed37e363bd7732ba2e;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/toke.c b/toke.c
index 87c94c1..8d8ac54 100644
--- a/toke.c
+++ b/toke.c
@@ -26,6 +26,8 @@
 #define yylval	PL_yylval
 
 static char ident_too_long[] = "Identifier too long";
+static char c_without_g[] = "Use of /c modifier is meaningless without /g";
+static char c_in_subst[] = "Use of /c modifier is meaningless in s///";
 
 static void restore_rsfp(pTHX_ void *f);
 #ifndef PERL_NO_UTF16_FILTER
@@ -39,11 +41,7 @@ static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
 #ifdef USE_UTF8_SCRIPTS
 #   define UTF (!IN_BYTES)
 #else
-#   ifdef EBCDIC /* For now 'use utf8' does not affect tokenizer on EBCDIC */
-#       define UTF (PL_linestr && DO_UTF8(PL_linestr))
-#   else
-#       define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
-#   endif
+#   define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
 #endif
 
 /* In variables named $^X, these are the legal values for X.
@@ -300,7 +298,7 @@ S_missingterm(pTHX_ char *s)
 	s = tmpbuf;
     }
     else {
-	*tmpbuf = PL_multi_close;
+	*tmpbuf = (char)PL_multi_close;
 	tmpbuf[1] = '\0';
 	s = tmpbuf;
     }
@@ -709,7 +707,7 @@ S_lop(pTHX_ I32 f, int x, char *s)
     PL_expect = x;
     PL_bufptr = s;
     PL_last_lop = PL_oldbufptr;
-    PL_last_lop_op = f;
+    PL_last_lop_op = (OPCODE)f;
     if (PL_nexttoke)
 	return LSTOP;
     if (*s == '(')
@@ -1067,7 +1065,7 @@ S_sublex_push(pTHX)
     *PL_lex_casestack = '\0';
     PL_lex_starts = 0;
     PL_lex_state = LEX_INTERPCONCAT;
-    CopLINE_set(PL_curcop, PL_multi_start);
+    CopLINE_set(PL_curcop, (line_t)PL_multi_start);
 
     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
@@ -1179,7 +1177,7 @@ S_sublex_done(pTHX)
   It stops processing as soon as it finds an embedded $ or @ variable
   and leaves it to the caller to work out what's going on.
 
-  @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
+  @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
 
   $ in pattern could be $foo or could be tail anchor.  Assumption:
   it's a tail anchor if $ is the last thing in the string, or if it's
@@ -1286,7 +1284,7 @@ S_scan_const(pTHX_ char *start)
 		else
 #endif
 		    for (i = min; i <= max; i++)
-			*d++ = i;
+			*d++ = (char)i;
 
 		/* mark the range as done, and continue */
 		dorange = FALSE;
@@ -1354,7 +1352,7 @@ S_scan_const(pTHX_ char *start)
 	}
 
 	/* check for embedded arrays
-	   (@foo, @:foo, @'foo, @{foo}, @$foo, @+, @-)
+	   (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
 	   */
 	else if (*s == '@' && s[1]
 		 && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
@@ -1494,8 +1492,8 @@ S_scan_const(pTHX_ char *start)
 			    while (src >= (U8 *)SvPVX(sv)) {
 			        if (!NATIVE_IS_INVARIANT(*src)) {
 				    U8 ch = NATIVE_TO_ASCII(*src);
-				    *dst-- = UTF8_EIGHT_BIT_LO(ch);
-				    *dst-- = UTF8_EIGHT_BIT_HI(ch);
+				    *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
+				    *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
 			        }
 			        else {
 				    *dst-- = *src;
@@ -1538,6 +1536,16 @@ S_scan_const(pTHX_ char *start)
 			e = s - 1;
 			goto cont_scan;
 		    }
+		    if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
+		        /* \N{U+...} */
+		        I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
+			  PERL_SCAN_DISALLOW_PREFIX;
+		        s += 3;
+			len = e - s;
+			uv = grok_hex(s, &len, &flags, NULL);
+			s = e + 1;
+			goto NUM_ESCAPE_INSERT;
+		    }
 		    res = newSVpvn(s + 1, e - s - 1);
 		    res = new_constant( Nullch, 0, "charnames",
 					res, Nullsv, "\\N{...}" );
@@ -1571,11 +1579,11 @@ S_scan_const(pTHX_ char *start)
 			*d = '\0';
 			sv_utf8_upgrade(sv);
 			/* this just broke our allocation above... */
-			SvGROW(sv, send - start);
+			SvGROW(sv, (STRLEN)(send - start));
 			d = SvPVX(sv) + SvCUR(sv);
 			has_utf8 = TRUE;
 		    }
-		    if (len > e - s + 4) { /* I _guess_ 4 is \N{} --jhi */
+		    if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
 			char *odest = SvPVX(sv);
 
 			SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
@@ -1862,7 +1870,7 @@ S_intuit_more(pTHX_ register char *s)
  * Method if it's "foo $bar"
  * Not a method if it's really "print foo $bar"
  * Method if it's really "foo package::" (interpreted as package->foo)
- * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
+ * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
  * Not a method if bar is a filehandle or package, but is quoted with
  *   =>
  */
@@ -2037,7 +2045,7 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
 	    int old_len = SvCUR(buf_sv) ;
 
 	    /* ensure buf_sv is large enough */
-	    SvGROW(buf_sv, old_len + maxlen) ;
+	    SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
 	    if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
 		if (PerlIO_error(PL_rsfp))
 	            return -1;		/* error */
@@ -2249,7 +2257,7 @@ Perl_yylex(pTHX)
               "### Saw case modifier at '%s'\n", PL_bufptr); });
 	    s = PL_bufptr + 1;
 	    if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
-		tmp = *s, *s = s[2], s[2] = tmp;	/* misordered... */
+		tmp = *s, *s = s[2], s[2] = (char)tmp;	/* misordered... */
 	    if (strchr("LU", *s) &&
 		(strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
 	    {
@@ -2533,7 +2541,7 @@ Perl_yylex(pTHX)
 		if (!PL_preprocess)
 		    bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
 #else
-		bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
+		bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
 #endif
 		if (bof) {
 		    PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
@@ -2606,6 +2614,19 @@ Perl_yylex(pTHX)
 			sv_setpvn(x, ipath, ipathend - ipath);
 			SvSETMAGIC(x);
 		    }
+		    else {
+			STRLEN blen;
+			STRLEN llen;
+			char *bstart = SvPV(CopFILESV(PL_curcop),blen);
+			char *lstart = SvPV(x,llen);
+			if (llen < blen) {
+			    bstart += blen - llen;
+			    if (strnEQ(bstart, lstart, llen) &&	bstart[-1] == '/') {
+				sv_setpvn(x, ipath, ipathend - ipath);
+				SvSETMAGIC(x);
+			    }
+			}
+		    }
 		    TAINT_NOT;	/* $^X is always tainted, but that's OK */
 		}
 #endif /* ARG_ZERO_IS_SCRIPT */
@@ -2828,7 +2849,7 @@ Perl_yylex(pTHX)
 		break;
 	    }
 	    if (ftst) {
-		PL_last_lop_op = ftst;
+		PL_last_lop_op = (OPCODE)ftst;
 		DEBUG_T( { PerlIO_printf(Perl_debug_log,
                         "### Saw file test %c\n", (int)ftst);
 		} );
@@ -2990,6 +3011,8 @@ Perl_yylex(pTHX)
 		    PL_lex_stuff = Nullsv;
 		}
 		else {
+		    /* NOTE: any CV attrs applied here need to be part of
+		       the CVf_BUILTIN_ATTRS define in cv.h! */
 		    if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
 			CvLVALUE_on(PL_compcv);
 		    else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
@@ -2997,14 +3020,20 @@ Perl_yylex(pTHX)
 		    else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
 			CvMETHOD_on(PL_compcv);
 #ifdef USE_ITHREADS
-      else if (PL_in_my == KEY_our && len == 6 && strnEQ(s, "unique", len))
+		    else if (PL_in_my == KEY_our && len == 6 &&
+			     strnEQ(s, "unique", len))
 			GvUNIQUE_on(cGVOPx_gv(yylval.opval));
 #endif
 		    /* After we've set the flags, it could be argued that
 		       we don't need to do the attributes.pm-based setting
 		       process, and shouldn't bother appending recognized
-		       flags. To experiment with that, uncomment the
-		       following "else": */
+		       flags.  To experiment with that, uncomment the
+		       following "else".  (Note that's already been
+		       uncommented.  That keeps the above-applied built-in
+		       attributes from being intercepted (and possibly
+		       rejected) by a package's attribute routines, but is
+		       justified by the performance win for the common case
+		       of applying only built-in attributes.) */
 		    else
 		        attrs = append_elem(OP_LIST, attrs,
 					    newSVOP(OP_CONST, 0,
@@ -3897,6 +3926,10 @@ Perl_yylex(pTHX)
 		CLINE;
 		yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
 		yylval.opval->op_private = OPpCONST_BARE;
+		/* UTF-8 package name? */
+		if (UTF && !IN_BYTES &&
+		    is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
+		    SvUTF8_on(sv);
 
 		/* And if "Foo::", then that's what it certainly is. */
 
@@ -4031,7 +4064,7 @@ Perl_yylex(pTHX)
 		    if (ckWARN(WARN_RESERVED)) {
 			if (lastchar != '-') {
 			    for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
-			    if (!*d && strNE(PL_tokenbuf,"main"))
+			    if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
 				Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
 				       PL_tokenbuf);
 			}
@@ -6237,7 +6270,7 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des
 }
 
 void
-Perl_pmflag(pTHX_ U16 *pmfl, int ch)
+Perl_pmflag(pTHX_ U32* pmfl, int ch)
 {
     if (ch == 'i')
 	*pmfl |= PMf_FOLD;
@@ -6276,6 +6309,13 @@ S_scan_pat(pTHX_ char *start, I32 type)
 	while (*s && strchr("iogcmsx", *s))
 	    pmflag(&pm->op_pmflags,*s++);
     }
+    /* issue a warning if /c is specified,but /g is not */
+    if (ckWARN(WARN_REGEXP) && 
+        (pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
+    {
+        Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
+    }
+
     pm->op_pmpermflags = pm->op_pmflags;
 
     PL_lex_op = (OP*)pm;
@@ -6324,6 +6364,12 @@ S_scan_subst(pTHX_ char *start)
 	    break;
     }
 
+    /* /c is not meaningful with s/// */
+    if (ckWARN(WARN_REGEXP) && (pm->op_pmflags & PMf_CONTINUE))
+    {
+        Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
+    }
+
     if (es) {
 	SV *repl;
 	PL_sublex_info.super_bufptr = s;
@@ -6500,7 +6546,7 @@ S_scan_heredoc(pTHX_ register char *s)
 		CopLINE_inc(PL_curcop);
 	}
 	if (s >= bufend) {
-	    CopLINE_set(PL_curcop, PL_multi_start);
+	    CopLINE_set(PL_curcop, (line_t)PL_multi_start);
 	    missingterm(PL_tokenbuf);
 	}
 	sv_setpvn(herewas,bufptr,d-bufptr+1);
@@ -6520,7 +6566,7 @@ S_scan_heredoc(pTHX_ register char *s)
 		CopLINE_inc(PL_curcop);
 	}
 	if (s >= PL_bufend) {
-	    CopLINE_set(PL_curcop, PL_multi_start);
+	    CopLINE_set(PL_curcop, (line_t)PL_multi_start);
 	    missingterm(PL_tokenbuf);
 	}
 	sv_setpvn(tmpstr,d+1,s-d);
@@ -6538,7 +6584,7 @@ S_scan_heredoc(pTHX_ register char *s)
     while (s >= PL_bufend) {	/* multiple line string? */
 	if (!outer ||
 	 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
-	    CopLINE_set(PL_curcop, PL_multi_start);
+	    CopLINE_set(PL_curcop, (line_t)PL_multi_start);
 	    missingterm(PL_tokenbuf);
 	}
 	CopLINE_inc(PL_curcop);
@@ -6931,7 +6977,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
 	if (!PL_rsfp ||
 	 !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
 	    sv_free(sv);
-	    CopLINE_set(PL_curcop, PL_multi_start);
+	    CopLINE_set(PL_curcop, (line_t)PL_multi_start);
 	    return Nullch;
 	}
 	/* we read a line, so increment our line counter */
@@ -7548,15 +7594,33 @@ Perl_yyerror(pTHX_ char *s)
 	where = "at EOF";
     else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
       PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
+	/*
+		Only for NetWare:
+		The code below is removed for NetWare because it abends/crashes on NetWare
+		when the script has error such as not having the closing quotes like:
+		    if ($var eq "value)
+		Checking of white spaces is anyway done in NetWare code.
+	*/
+#ifndef NETWARE
 	while (isSPACE(*PL_oldoldbufptr))
 	    PL_oldoldbufptr++;
+#endif
 	context = PL_oldoldbufptr;
 	contlen = PL_bufptr - PL_oldoldbufptr;
     }
     else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
       PL_oldbufptr != PL_bufptr) {
+	/*
+		Only for NetWare:
+		The code below is removed for NetWare because it abends/crashes on NetWare
+		when the script has error such as not having the closing quotes like:
+		    if ($var eq "value)
+		Checking of white spaces is anyway done in NetWare code.
+	*/
+#ifndef NETWARE
 	while (isSPACE(*PL_oldbufptr))
 	    PL_oldbufptr++;
+#endif
 	context = PL_oldbufptr;
 	contlen = PL_bufptr - PL_oldbufptr;
     }