This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate:
[perl5.git] / toke.c
diff --git a/toke.c b/toke.c
index d95b0a7..5e8189f 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -1,6 +1,6 @@
 /*    toke.c
  *
- *    Copyright (c) 1991-2002, Larry Wall
+ *    Copyright (c) 1991-2003, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -149,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 = XTERMORDORDOR,PL_bufptr = s,(int)UNIOP)
+#define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERM,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))
@@ -164,18 +164,14 @@ 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 UNI2(f,x) return(yylval.ival = f, \
+#define UNI(f) return(yylval.ival = f, \
        REPORT("uni",f) \
-       PL_expect = x, \
+       PL_expect = XTERM, \
        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 +207,8 @@ S_tokereport(pTHX_ char *thing, char* s, I32 rv)
 /*
  * S_ao
  *
- * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
- * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
+ * This subroutine detects &&= and ||= and turns an ANDAND or OROR
+ * into an OP_ANDASSIGN or OP_ORASSIGN
  */
 
 STATIC int
@@ -224,8 +220,6 @@ 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;
@@ -424,8 +418,8 @@ Perl_lex_start(pTHX_ SV *line)
     SAVEPPTR(PL_last_uni);
     SAVEPPTR(PL_linestart);
     SAVESPTR(PL_linestr);
-    SAVEPPTR(PL_lex_brackstack);
-    SAVEPPTR(PL_lex_casestack);
+    SAVEGENERICPV(PL_lex_brackstack);
+    SAVEGENERICPV(PL_lex_casestack);
     SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
     SAVESPTR(PL_lex_stuff);
     SAVEI32(PL_lex_defer);
@@ -440,8 +434,6 @@ Perl_lex_start(pTHX_ SV *line)
     PL_lex_brackets = 0;
     New(899, PL_lex_brackstack, 120, char);
     New(899, PL_lex_casestack, 12, char);
-    SAVEFREEPV(PL_lex_brackstack);
-    SAVEFREEPV(PL_lex_casestack);
     PL_lex_casemods = 0;
     *PL_lex_casestack = '\0';
     PL_lex_dojoin = 0;
@@ -1001,9 +993,6 @@ 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;
     }
 
@@ -1052,8 +1041,8 @@ S_sublex_push(pTHX)
     SAVEPPTR(PL_last_uni);
     SAVEPPTR(PL_linestart);
     SAVESPTR(PL_linestr);
-    SAVEPPTR(PL_lex_brackstack);
-    SAVEPPTR(PL_lex_casestack);
+    SAVEGENERICPV(PL_lex_brackstack);
+    SAVEGENERICPV(PL_lex_casestack);
 
     PL_linestr = PL_lex_stuff;
     PL_lex_stuff = Nullsv;
@@ -1068,8 +1057,6 @@ S_sublex_push(pTHX)
     PL_lex_brackets = 0;
     New(899, PL_lex_brackstack, 120, char);
     New(899, PL_lex_casestack, 12, char);
-    SAVEFREEPV(PL_lex_brackstack);
-    SAVEFREEPV(PL_lex_casestack);
     PL_lex_casemods = 0;
     *PL_lex_casestack = '\0';
     PL_lex_starts = 0;
@@ -1611,7 +1598,7 @@ S_scan_const(pTHX_ char *start)
            /* \c is a control character */
            case 'c':
                s++;
-               {
+               if (s < send) {
                    U8 c = *s++;
 #ifdef EBCDIC
                    if (isLOWER(c))
@@ -1619,6 +1606,9 @@ S_scan_const(pTHX_ char *start)
 #endif
                    *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
                }
+               else {
+                   yyerror("Missing control char name in \\c");
+               }
                continue;
 
            /* printf-style backslashes, formfeeds, newlines, etc */
@@ -2205,6 +2195,7 @@ Perl_yylex(pTHX)
     GV *gv = Nullgv;
     GV **gvp = 0;
     bool bof = FALSE;
+    I32 orig_keyword = 0;
 
     /* check if there's an identifier for us to look at */
     if (PL_pending_ident)
@@ -2266,39 +2257,40 @@ Perl_yylex(pTHX)
            DEBUG_T({ PerlIO_printf(Perl_debug_log,
               "### 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] = (char)tmp;  /* misordered... */
-           if (strchr("LU", *s) &&
-               (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
-           {
-               PL_lex_casestack[--PL_lex_casemods] = '\0';
-               return ')';
+           if (s[1] == '\\' && s[2] == 'E') {
+               PL_bufptr = s + 3;
+               PL_lex_state = LEX_INTERPCONCAT;
+               return yylex();
            }
-           if (PL_lex_casemods > 10) {
-               char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
-               if (newlb != PL_lex_casestack) {
-                   SAVEFREEPV(newlb);
-                   PL_lex_casestack = newlb;
+           else {
+               if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
+                   tmp = *s, *s = s[2], s[2] = (char)tmp;      /* misordered... */
+               if (strchr("LU", *s) &&
+                   (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
+                   PL_lex_casestack[--PL_lex_casemods] = '\0';
+                   return ')';
                }
+               if (PL_lex_casemods > 10)
+                   Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
+               PL_lex_casestack[PL_lex_casemods++] = *s;
+               PL_lex_casestack[PL_lex_casemods] = '\0';
+               PL_lex_state = LEX_INTERPCONCAT;
+               PL_nextval[PL_nexttoke].ival = 0;
+               force_next('(');
+               if (*s == 'l')
+                   PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
+               else if (*s == 'u')
+                   PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
+               else if (*s == 'L')
+                   PL_nextval[PL_nexttoke].ival = OP_LC;
+               else if (*s == 'U')
+                   PL_nextval[PL_nexttoke].ival = OP_UC;
+               else if (*s == 'Q')
+                   PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
+               else
+                   Perl_croak(aTHX_ "panic: yylex");
+               PL_bufptr = s + 1;
            }
-           PL_lex_casestack[PL_lex_casemods++] = *s;
-           PL_lex_casestack[PL_lex_casemods] = '\0';
-           PL_lex_state = LEX_INTERPCONCAT;
-           PL_nextval[PL_nexttoke].ival = 0;
-           force_next('(');
-           if (*s == 'l')
-               PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
-           else if (*s == 'u')
-               PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
-           else if (*s == 'L')
-               PL_nextval[PL_nexttoke].ival = OP_LC;
-           else if (*s == 'U')
-               PL_nextval[PL_nexttoke].ival = OP_UC;
-           else if (*s == 'Q')
-               PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
-           else
-               Perl_croak(aTHX_ "panic: yylex");
-           PL_bufptr = s + 1;
            force_next(FUNC);
            if (PL_lex_starts) {
                s = PL_bufptr;
@@ -2323,7 +2315,13 @@ Perl_yylex(pTHX)
        if (PL_lex_dojoin) {
            PL_nextval[PL_nexttoke].ival = 0;
            force_next(',');
+#ifdef USE_5005THREADS
+           PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
+           PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
+           force_next(PRIVATEREF);
+#else
            force_ident("\"", '$');
+#endif /* USE_5005THREADS */
            PL_nextval[PL_nexttoke].ival = 0;
            force_next('$');
            PL_nextval[PL_nexttoke].ival = 0;
@@ -2983,7 +2981,6 @@ Perl_yylex(pTHX)
                    switch (tmp) {
                    case KEY_or:
                    case KEY_and:
-                   case KEY_err:
                    case KEY_for:
                    case KEY_unless:
                    case KEY_if:
@@ -3113,11 +3110,7 @@ Perl_yylex(pTHX)
       leftbracket:
        s++;
        if (PL_lex_brackets > 100) {
-           char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
-           if (newlb != PL_lex_brackstack) {
-               SAVEFREEPV(newlb);
-               PL_lex_brackstack = newlb;
-           }
+           Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
        }
        switch (PL_expect) {
        case XTERM:
@@ -3547,11 +3540,8 @@ 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 (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
-               PL_expect = XTERM;              /* e.g. print $fh /.../
-                                                XXX except DORDOR operator */
+           else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
+               PL_expect = XTERM;              /* e.g. print $fh -1 */
            else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
                PL_expect = XTERM;              /* print $fh <<"EOF" */
        }
@@ -3593,40 +3583,22 @@ Perl_yylex(pTHX)
        PL_pending_ident = '@';
        TERM('@');
 
-     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 '/':                  /* 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 '.':
        if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
@@ -3746,9 +3718,7 @@ 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
-                       || PL_expect == XTERMORDORDOR)) {
+           else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE)) {
                char c = *start;
                GV *gv;
                *start = '\0';
@@ -3797,7 +3767,7 @@ Perl_yylex(pTHX)
     case 'z': case 'Z':
 
       keylookup: {
-       I32 orig_keyword = 0;
+       orig_keyword = 0;
        gv = Nullgv;
        gvp = 0;
 
@@ -4189,8 +4159,29 @@ Perl_yylex(pTHX)
                }
 #endif
 #ifdef PERLIO_LAYERS
-               if (UTF && !IN_BYTES)
-                   PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
+               if (!IN_BYTES) {
+                   if (UTF)
+                       PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
+                   else if (PL_encoding) {
+                       SV *name;
+                       dSP;
+                       ENTER;
+                       SAVETMPS;
+                       PUSHMARK(sp);
+                       EXTEND(SP, 1);
+                       XPUSHs(PL_encoding);
+                       PUTBACK;
+                       call_method("name", G_SCALAR);
+                       SPAGAIN;
+                       name = POPs;
+                       PUTBACK;
+                       PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, 
+                                           Perl_form(aTHX_ ":encoding(%"SVf")",
+                                                     name));
+                       FREETMPS;
+                       LEAVE;
+                   }
+               }
 #endif
                PL_rsfp = Nullfp;
            }
@@ -4348,9 +4339,6 @@ Perl_yylex(pTHX)
        case KEY_eof:
            UNI(OP_EOF);
 
-       case KEY_err:
-           OPERATOR(DOROP);
-
        case KEY_exp:
            UNI(OP_EXP);
 
@@ -4434,7 +4422,7 @@ Perl_yylex(pTHX)
            UNI(OP_GMTIME);
 
        case KEY_getc:
-           UNIDOR(OP_GETC);
+           UNI(OP_GETC);
 
        case KEY_getppid:
            FUN0(OP_GETPPID);
@@ -4688,10 +4676,10 @@ Perl_yylex(pTHX)
            LOP(OP_PUSH,XTERM);
 
        case KEY_pop:
-           UNIDOR(OP_POP);
+           UNI(OP_POP);
 
        case KEY_pos:
-           UNIDOR(OP_POS);
+           UNI(OP_POS);
        
        case KEY_pack:
            LOP(OP_PACK,XTERM);
@@ -4831,7 +4819,7 @@ Perl_yylex(pTHX)
 
        case KEY_readline:
            set_csh();
-           UNIDOR(OP_READLINE);
+           UNI(OP_READLINE);
 
        case KEY_readpipe:
            set_csh();
@@ -4847,7 +4835,7 @@ Perl_yylex(pTHX)
            LOP(OP_REVERSE,XTERM);
 
        case KEY_readlink:
-           UNIDOR(OP_READLINK);
+           UNI(OP_READLINK);
 
        case KEY_ref:
            UNI(OP_REF);
@@ -4914,7 +4902,7 @@ Perl_yylex(pTHX)
            LOP(OP_SSOCKOPT,XTERM);
 
        case KEY_shift:
-           UNIDOR(OP_SHIFT);
+           UNI(OP_SHIFT);
 
        case KEY_shmctl:
            LOP(OP_SHMCTL,XTERM);
@@ -5045,8 +5033,8 @@ Perl_yylex(pTHX)
                    d[tmp] = '\0';
                    if (bad_proto && ckWARN(WARN_SYNTAX))
                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
-                                   "Illegal character in prototype for %s : %s",
-                                   SvPVX(PL_subname), d);
+                                   "Illegal character in prototype for %"SVf" : %s",
+                                   PL_subname, d);
                    SvCUR(PL_lex_stuff) = tmp;
                    have_proto = TRUE;
 
@@ -5057,6 +5045,8 @@ Perl_yylex(pTHX)
 
                if (*s == ':' && s[1] != ':')
                    PL_expect = attrful;
+               else if (!have_name && *s != '{' && key == KEY_sub)
+                   Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
 
                if (have_proto) {
                    PL_nextval[PL_nexttoke].opval =
@@ -5144,7 +5134,7 @@ Perl_yylex(pTHX)
            LOP(OP_UNLINK,XTERM);
 
        case KEY_undef:
-           UNIDOR(OP_UNDEF);
+           UNI(OP_UNDEF);
 
        case KEY_unpack:
            LOP(OP_UNPACK,XTERM);
@@ -5153,7 +5143,7 @@ Perl_yylex(pTHX)
            LOP(OP_UTIME,XTERM);
 
        case KEY_umask:
-           UNIDOR(OP_UMASK);
+           UNI(OP_UMASK);
 
        case KEY_unshift:
            LOP(OP_UNSHIFT,XTERM);
@@ -5240,7 +5230,7 @@ static int
 S_pending_ident(pTHX)
 {
     register char *d;
-    register I32 tmp;
+    register I32 tmp = 0;
     /* pit holds the identifier we read and pending_ident is reset */
     char pit = PL_pending_ident;
     PL_pending_ident = 0;
@@ -5285,7 +5275,20 @@ S_pending_ident(pTHX)
     */
 
     if (!strchr(PL_tokenbuf,':')) {
-        if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
+#ifdef USE_5005THREADS
+        /* Check for single character per-thread SVs */
+        if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
+            && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
+            && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
+        {
+            yylval.opval = newOP(OP_THREADSV, 0);
+            yylval.opval->op_targ = tmp;
+            return PRIVATEREF;
+        }
+#endif /* USE_5005THREADS */
+       if (!PL_in_my)
+           tmp = pad_findmy(PL_tokenbuf);
+        if (tmp != NOT_IN_PAD) {
             /* might be an "our" variable" */
             if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
                 /* build ops for a bareword */
@@ -5465,7 +5468,6 @@ 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:
@@ -6273,8 +6275,10 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des
        }
        if (*s == '}') {
            s++;
-           if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
+           if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
                PL_lex_state = LEX_INTERPEND;
+               PL_expect = XREF;
+           }
            if (funny == '#')
                funny = '@';
            if (PL_lex_state == LEX_NORMAL) {
@@ -6881,6 +6885,10 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
     register char *to;                 /* current position in the sv's data */
     I32 brackets = 1;                  /* bracket nesting level */
     bool has_utf8 = FALSE;             /* is there any utf8 content? */
+    I32 termcode;                      /* terminating char. code */
+    U8 termstr[UTF8_MAXLEN];           /* terminating string */
+    STRLEN termlen;                    /* length of terminating string */
+    char *last = NULL;                 /* last position for nesting bracket */
 
     /* skip space before the delimiter */
     if (isSPACE(*s))
@@ -6891,8 +6899,16 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
 
     /* after skipping whitespace, the next character is the terminator */
     term = *s;
-    if (!UTF8_IS_INVARIANT((U8)term) && UTF)
-       has_utf8 = TRUE;
+    if (!UTF) {
+       termcode = termstr[0] = term;
+       termlen = 1;
+    }
+    else {
+       termcode = utf8_to_uvchr((U8*)s, &termlen);
+       Copy(s, termstr, termlen, U8);
+       if (!UTF8_IS_INVARIANT(term))
+           has_utf8 = TRUE;
+    }
 
     /* mark where we are */
     PL_multi_start = CopLINE(PL_curcop);
@@ -6900,21 +6916,92 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
 
     /* find corresponding closing delimiter */
     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
-       term = tmps[5];
+       termcode = termstr[0] = term = tmps[5];
+
     PL_multi_close = term;
 
     /* create a new SV to hold the contents.  87 is leak category, I'm
        assuming.  79 is the SV's initial length.  What a random number. */
     sv = NEWSV(87,79);
     sv_upgrade(sv, SVt_PVIV);
-    SvIVX(sv) = term;
+    SvIVX(sv) = termcode;
     (void)SvPOK_only(sv);              /* validate pointer */
 
     /* move past delimiter and try to read a complete string */
     if (keep_delims)
-       sv_catpvn(sv, s, 1);
-    s++;
+       sv_catpvn(sv, s, termlen);
+    s += termlen;
     for (;;) {
+       if (PL_encoding && !UTF) {
+           bool cont = TRUE;
+
+           while (cont) {
+               int offset = s - SvPVX(PL_linestr);
+               bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
+                                          &offset, (char*)termstr, termlen);
+               char *ns = SvPVX(PL_linestr) + offset;
+               char *svlast = SvEND(sv) - 1;
+
+               for (; s < ns; s++) {
+                   if (*s == '\n' && !PL_rsfp)
+                       CopLINE_inc(PL_curcop);
+               }
+               if (!found)
+                   goto read_more_line;
+               else {
+                   /* handle quoted delimiters */
+                   if (*(svlast-1) == '\\') {
+                       char *t;
+                       for (t = svlast-2; t >= SvPVX(sv) && *t == '\\';)
+                           t--;
+                       if ((svlast-1 - t) % 2) {
+                           if (!keep_quoted) {
+                               *(svlast-1) = term;
+                               *svlast = '\0';
+                               SvCUR_set(sv, SvCUR(sv) - 1);
+                           }
+                           continue;
+                       }
+                   }
+                   if (PL_multi_open == PL_multi_close) {
+                       cont = FALSE;
+                   }
+                   else {
+                       char *t, *w;
+                       if (!last)
+                           last = SvPVX(sv);
+                       for (w = t = last; t < svlast; w++, t++) {
+                           /* At here, all closes are "was quoted" one,
+                              so we don't check PL_multi_close. */
+                           if (*t == '\\') {
+                               if (!keep_quoted && *(t+1) == PL_multi_open)
+                                   t++;
+                               else
+                                   *w++ = *t++;
+                           }
+                           else if (*t == PL_multi_open)
+                               brackets++;
+
+                           *w = *t;
+                       }
+                       if (w < t) {
+                           *w++ = term;
+                           *w = '\0';
+                           SvCUR_set(sv, w - SvPVX(sv));
+                       }
+                       last = w;
+                       if (--brackets <= 0)
+                           cont = FALSE;
+                   }
+               }
+           }
+           if (!keep_delims) {
+               SvCUR_set(sv, SvCUR(sv) - 1);
+               *SvEND(sv) = '\0';
+           }
+           break;
+       }
+
        /* extend sv if need be */
        SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
        /* set 'to' to the next character in the sv's string */
@@ -6936,8 +7023,12 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
                }
                /* terminate when run out of buffer (the for() condition), or
                   have found the terminator */
-               else if (*s == term)
-                   break;
+               else if (*s == term) {
+                   if (termlen == 1)
+                       break;
+                   if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
+                       break;
+               }
                else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
                    has_utf8 = TRUE;
                *to = *s;
@@ -6999,6 +7090,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
            to[-1] = '\n';
 #endif
        
+     read_more_line:
        /* 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
        */
@@ -7029,15 +7121,15 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
 
     /* at this point, we have successfully read the delimited string */
 
-    if (keep_delims)
-       sv_catpvn(sv, s, 1);
-    if (has_utf8)
+    if (!PL_encoding || UTF) {
+       if (keep_delims)
+           sv_catpvn(sv, s, termlen);
+       s += termlen;
+    }
+    if (has_utf8 || PL_encoding)
        SvUTF8_on(sv);
-    else if (PL_encoding)
-       sv_recode_to_utf8(sv, PL_encoding);
 
     PL_multi_end = CopLINE(PL_curcop);
-    s++;
 
     /* if we allocated too much space, give some back */
     if (SvCUR(sv) + 5 < SvLEN(sv)) {
@@ -7437,7 +7529,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
     case 'v':
 vstring:
                sv = NEWSV(92,5); /* preallocate storage space */
-               s = scan_vstring(s,sv);
+               s = new_vstring(s,sv);
        break;
     }
 
@@ -7524,6 +7616,12 @@ S_scan_formline(pTHX_ register char *s)
        }
        else
            PL_lex_state = LEX_FORMLINE;
+       if (!IN_BYTES) {
+           if (UTF && is_utf8_string((U8*)SvPVX(stuff), SvCUR(stuff)))
+               SvUTF8_on(stuff);
+           else if (PL_encoding)
+               sv_recode_to_utf8(stuff, PL_encoding);
+       }
        PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
        force_next(THING);
        PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
@@ -7566,6 +7664,12 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
     PL_subline = CopLINE(PL_curcop);
     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
+    CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
+#ifdef USE_5005THREADS
+    CvOWNER(PL_compcv) = 0;
+    New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
+    MUTEX_INIT(CvMUTEXP(PL_compcv));
+#endif /* USE_5005THREADS */
 
     return oldsavestack_ix;
 }