fix parsing of here documents in C<eval 's/.../<<FOO/e'>

[p5sagit/p5-mst-13.2.git] / toke.c

diff --git a/toke.c b/toke.c
index 211f9b2..1a17904 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -74,6 +74,10 @@ static char ident_too_long[] = "Identifier too long";
                                ? isALNUM(*(p)) \
                                : isALNUM_utf8((U8*)p))
 
+/* In variables name $^X, these are the legal values for X.  
+ * 1999-02-27 mjd-perl-patch@plover.com */
+#define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
+
 /* The following are arranged oddly so that the guard on the switch statement
  * can get by with a single comparison (if the compiler is smart enough).
  */
@@ -1634,7 +1638,7 @@ int yylex(PERL_YYLEX_PARAM_DECL)
        */
        if (PL_in_my) {
            if (strchr(PL_tokenbuf,':'))
-               croak(PL_no_myglob,PL_tokenbuf);
+               yyerror(form(PL_no_myglob,PL_tokenbuf));
 
            yylval.opval = newOP(OP_PADANY, 0);
            yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
@@ -5160,7 +5164,7 @@ scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I3
     if (s < send)
        *d = *s++;
     d[1] = '\0';
-    if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
+    if (*d == '^' && *s && isCONTROLVAR(*s)) {
        *d = toCTRL(*s);
        s++;
     }
@@ -5188,8 +5192,10 @@ scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I3
                s = e;
            }
            else {
-               while (isALNUM(*s) || *s == ':')
+               while ((isALNUM(*s) || *s == ':') && d < e)
                    *d++ = *s++;
+               if (d >= e)
+                   croak(ident_too_long);
            }
            *d = '\0';
            while (s < send && (*s == ' ' || *s == '\t')) s++;
@@ -5206,6 +5212,19 @@ scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I3
                PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
                return s;
            }
+       } 
+       /* Handle extended ${^Foo} variables 
+        * 1999-02-27 mjd-perl-patch@plover.com */
+       else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
+                && isALNUM(*s))
+       {
+           d++;
+           while (isALNUM(*s) && d < e) {
+               *d++ = *s++;
+           }
+           if (d >= e)
+               croak(ident_too_long);
+           *d = '\0';
        }
        if (*s == '}') {
            s++;
@@ -5333,6 +5352,9 @@ scan_subst(char *start)
 
     if (es) {
        SV *repl;
+       PL_sublex_info.super_bufptr = s;
+       PL_sublex_info.super_bufend = PL_bufend;
+       PL_multi_end = 0;
        pm->op_pmflags |= PMf_EVAL;
        repl = newSVpv("",0);
        while (es-- > 0)
@@ -5522,7 +5544,33 @@ scan_heredoc(register char *s)
     PL_multi_start = PL_curcop->cop_line;
     PL_multi_open = PL_multi_close = '<';
     term = *PL_tokenbuf;
-    if (!outer) {
+    if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
+       char *bufptr = PL_sublex_info.super_bufptr;
+       char *bufend = PL_sublex_info.super_bufend;
+       char *olds = s - SvCUR(herewas);
+       s = strchr(bufptr, '\n');
+       if (!s)
+           s = bufend;
+       d = s;
+       while (s < bufend &&
+         (*s != term || memNE(s,PL_tokenbuf,len)) ) {
+           if (*s++ == '\n')
+               PL_curcop->cop_line++;
+       }
+       if (s >= bufend) {
+           PL_curcop->cop_line = PL_multi_start;
+           missingterm(PL_tokenbuf);
+       }
+       sv_setpvn(herewas,bufptr,d-bufptr+1);
+       sv_setpvn(tmpstr,d+1,s-d);
+       s += len - 1;
+       sv_catpvn(herewas,s,bufend-s);
+       (void)strcpy(bufptr,SvPVX(herewas));
+
+       s = olds;
+       goto retval;
+    }
+    else if (!outer) {
        d = s;
        while (s < PL_bufend &&
          (*s != term || memNE(s,PL_tokenbuf,len)) ) {
@@ -5586,8 +5634,9 @@ scan_heredoc(register char *s)
            sv_catsv(tmpstr,PL_linestr);
        }
     }
-    PL_multi_end = PL_curcop->cop_line;
     s++;
+retval:
+    PL_multi_end = PL_curcop->cop_line;
     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
        SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
        Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);