X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=fa0f1ac479e293aa163ba9cb278a26125a832885;hb=718842b0e14b2d067314bf35e22eac61894424e9;hp=cf04cfa68e49b426dacc9f332fe94761addbf853;hpb=eb160463266f58ba83ae9bb9ae8bbdc8f0c3027b;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/toke.c b/toke.c
index cf04cfa..fa0f1ac 100644
--- a/toke.c
+++ b/toke.c
@@ -41,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.
@@ -153,7 +149,7 @@ int yyactlevel = -1;
 #define PREREF(retval) return (REPORT2("preref",retval) PL_expect = XREF,PL_bufptr = s,(int)retval)
 #define TERM(retval) return (CLINE, REPORT2("term",retval) PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
 #define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f) PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
-#define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
+#define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERMORDORDOR,PL_bufptr = s,(int)UNIOP)
 #define FUN0(f) return(yylval.ival = f, REPORT("fun0",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
 #define FUN1(f) return(yylval.ival = f, REPORT("fun1",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
 #define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
@@ -168,14 +164,18 @@ int yyactlevel = -1;
 
 /* This bit of chicanery makes a unary function followed by
  * a parenthesis into a function with one argument, highest precedence.
+ * The UNIDOR macro is for unary functions that can be followed by the //
+ * operator (such as C<shift // 0>).
  */
-#define UNI(f) return(yylval.ival = f, \
+#define UNI2(f,x) return(yylval.ival = f, \
 	REPORT("uni",f) \
-	PL_expect = XTERM, \
+	PL_expect = x, \
 	PL_bufptr = s, \
 	PL_last_uni = PL_oldbufptr, \
 	PL_last_lop_op = f, \
 	(*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
+#define UNI(f)    UNI2(f,XTERM)
+#define UNIDOR(f) UNI2(f,XTERMORDORDOR)
 
 #define UNIBRACK(f) return(yylval.ival = f, \
         REPORT("uni",f) \
@@ -211,8 +211,8 @@ S_tokereport(pTHX_ char *thing, char* s, I32 rv)
 /*
  * S_ao
  *
- * This subroutine detects &&= and ||= and turns an ANDAND or OROR
- * into an OP_ANDASSIGN or OP_ORASSIGN
+ * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
+ * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
  */
 
 STATIC int
@@ -224,6 +224,8 @@ S_ao(pTHX_ int toketype)
 	    yylval.ival = OP_ANDASSIGN;
 	else if (toketype == OROR)
 	    yylval.ival = OP_ORASSIGN;
+	else if (toketype == DORDOR)
+	    yylval.ival = OP_DORASSIGN;
 	toketype = ASSIGNOP;
     }
     return toketype;
@@ -454,7 +456,7 @@ Perl_lex_start(pTHX_ SV *line)
     if (SvREADONLY(PL_linestr))
 	PL_linestr = sv_2mortal(newSVsv(PL_linestr));
     s = SvPV(PL_linestr, len);
-    if (len && s[len-1] != ';') {
+    if (!len || s[len-1] != ';') {
 	if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
 	    PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 	sv_catpvn(PL_linestr, "\n;", 2);
@@ -999,6 +1001,9 @@ S_sublex_start(pTHX)
 	}
 	yylval.opval = (OP*)newSVOP(op_type, 0, sv);
 	PL_lex_stuff = Nullsv;
+	/* Allow <FH> // "foo" */
+	if (op_type == OP_READLINE)
+	    PL_expect = XTERMORDORDOR;
 	return THING;
     }
 
@@ -1540,6 +1545,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{...}" );
@@ -1864,7 +1879,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
  *   =>
  */
@@ -2608,6 +2623,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 */
@@ -2960,6 +2988,7 @@ Perl_yylex(pTHX)
 		    switch (tmp) {
 		    case KEY_or:
 		    case KEY_and:
+		    case KEY_err:
 		    case KEY_for:
 		    case KEY_unless:
 		    case KEY_if:
@@ -3027,7 +3056,7 @@ Perl_yylex(pTHX)
 		    break;	/* require real whitespace or :'s */
 	    }
 	    tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
-	    if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
+	    if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
 		char q = ((*s == '\'') ? '"' : '\'');
 		/* If here for an expression, and parsed no attrs, back off. */
 		if (tmp == '=' && !attrs) {
@@ -3523,8 +3552,11 @@ Perl_yylex(pTHX)
 		PL_expect = XTERM;		/* e.g. print $fh 3 */
 	    else if (*s == '.' && isDIGIT(s[1]))
 		PL_expect = XTERM;		/* e.g. print $fh .3 */
-	    else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
-		PL_expect = XTERM;		/* e.g. print $fh -1 */
+	    else if (strchr("?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
+ 		PL_expect = XTERM;		/* e.g. print $fh -1 */
+	    else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
+		PL_expect = XTERM;		/* e.g. print $fh /.../
+						 XXX except DORDOR operator */
 	    else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
 		PL_expect = XTERM;		/* print $fh <<"EOF" */
 	}
@@ -3566,22 +3598,40 @@ Perl_yylex(pTHX)
 	PL_pending_ident = '@';
 	TERM('@');
 
-    case '/':			/* may either be division or pattern */
-    case '?':			/* may either be conditional or pattern */
-	if (PL_expect != XOPERATOR) {
-	    /* Disable warning on "study /blah/" */
-	    if (PL_oldoldbufptr == PL_last_uni
-		&& (*PL_last_uni != 's' || s - PL_last_uni < 5
-		    || memNE(PL_last_uni, "study", 5)
-		    || isALNUM_lazy_if(PL_last_uni+5,UTF)))
-		check_uni();
-	    s = scan_pat(s,OP_MATCH);
-	    TERM(sublex_start());
-	}
-	tmp = *s++;
-	if (tmp == '/')
-	    Mop(OP_DIVIDE);
-	OPERATOR(tmp);
+     case '/':			/* may be division, defined-or, or pattern */
+	if (PL_expect == XTERMORDORDOR && s[1] == '/') {
+	    s += 2;
+	    AOPERATOR(DORDOR);
+	}
+     case '?':			/* may either be conditional or pattern */
+	 if(PL_expect == XOPERATOR) {
+	     tmp = *s++;
+	     if(tmp == '?') {
+    	          OPERATOR('?');
+	     }
+             else {
+	         tmp = *s++;
+	         if(tmp == '/') {
+	             /* A // operator. */
+	            AOPERATOR(DORDOR);
+	         }
+	         else {
+	             s--;
+	             Mop(OP_DIVIDE);
+	         }
+	     }
+	 }
+	 else {
+	     /* Disable warning on "study /blah/" */
+	     if (PL_oldoldbufptr == PL_last_uni
+	      && (*PL_last_uni != 's' || s - PL_last_uni < 5
+	          || memNE(PL_last_uni, "study", 5)
+	          || isALNUM_lazy_if(PL_last_uni+5,UTF)
+	      ))
+	         check_uni();
+	     s = scan_pat(s,OP_MATCH);
+	     TERM(sublex_start());
+	 }
 
     case '.':
 	if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
@@ -3701,7 +3751,9 @@ Perl_yylex(pTHX)
 		TERM(THING);
 	    }
 	    /* avoid v123abc() or $h{v1}, allow C<print v10;> */
-	    else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE)) {
+	    else if (!isALPHA(*start) && (PL_expect == XTERM
+			|| PL_expect == XREF || PL_expect == XSTATE
+			|| PL_expect == XTERMORDORDOR)) {
 		char c = *start;
 		GV *gv;
 		*start = '\0';
@@ -3907,6 +3959,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. */
 
@@ -4041,7 +4097,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);
 			}
@@ -4293,6 +4349,9 @@ Perl_yylex(pTHX)
 	case KEY_eof:
 	    UNI(OP_EOF);
 
+	case KEY_err:
+	    OPERATOR(DOROP);
+
 	case KEY_exp:
 	    UNI(OP_EXP);
 
@@ -4376,7 +4435,7 @@ Perl_yylex(pTHX)
 	    UNI(OP_GMTIME);
 
 	case KEY_getc:
-	    UNI(OP_GETC);
+	    UNIDOR(OP_GETC);
 
 	case KEY_getppid:
 	    FUN0(OP_GETPPID);
@@ -4626,10 +4685,10 @@ Perl_yylex(pTHX)
 	    LOP(OP_PUSH,XTERM);
 
 	case KEY_pop:
-	    UNI(OP_POP);
+	    UNIDOR(OP_POP);
 
 	case KEY_pos:
-	    UNI(OP_POS);
+	    UNIDOR(OP_POS);
 	
 	case KEY_pack:
 	    LOP(OP_PACK,XTERM);
@@ -4769,7 +4828,7 @@ Perl_yylex(pTHX)
 
 	case KEY_readline:
 	    set_csh();
-	    UNI(OP_READLINE);
+	    UNIDOR(OP_READLINE);
 
 	case KEY_readpipe:
 	    set_csh();
@@ -4785,7 +4844,7 @@ Perl_yylex(pTHX)
 	    LOP(OP_REVERSE,XTERM);
 
 	case KEY_readlink:
-	    UNI(OP_READLINK);
+	    UNIDOR(OP_READLINK);
 
 	case KEY_ref:
 	    UNI(OP_REF);
@@ -4852,7 +4911,7 @@ Perl_yylex(pTHX)
 	    LOP(OP_SSOCKOPT,XTERM);
 
 	case KEY_shift:
-	    UNI(OP_SHIFT);
+	    UNIDOR(OP_SHIFT);
 
 	case KEY_shmctl:
 	    LOP(OP_SHMCTL,XTERM);
@@ -5082,7 +5141,7 @@ Perl_yylex(pTHX)
 	    LOP(OP_UNLINK,XTERM);
 
 	case KEY_undef:
-	    UNI(OP_UNDEF);
+	    UNIDOR(OP_UNDEF);
 
 	case KEY_unpack:
 	    LOP(OP_UNPACK,XTERM);
@@ -5091,7 +5150,7 @@ Perl_yylex(pTHX)
 	    LOP(OP_UTIME,XTERM);
 
 	case KEY_umask:
-	    UNI(OP_UMASK);
+	    UNIDOR(OP_UMASK);
 
 	case KEY_unshift:
 	    LOP(OP_UNSHIFT,XTERM);
@@ -5415,6 +5474,7 @@ Perl_keyword(pTHX_ register char *d, I32 len)
 	    break;
 	case 3:
 	    if (strEQ(d,"eof"))			return -KEY_eof;
+	    if (strEQ(d,"err"))			return -KEY_err;
 	    if (strEQ(d,"exp"))			return -KEY_exp;
 	    break;
 	case 4:
@@ -6247,7 +6307,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;
@@ -7383,7 +7443,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
     case 'v':
 vstring:
 		sv = NEWSV(92,5); /* preallocate storage space */
-		s = new_vstring(s,sv);
+		s = scan_vstring(s,sv);
 	break;
     }
 
@@ -7571,15 +7631,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;
     }