Typo/thinko in S_scan_const() - seeing high bit sets has_utf8 not this_utf8
Nick Ing-Simmons [Sat, 9 Dec 2000 19:09:41 +0000 (19:09 +0000)]
i.e. the output string has one, but don't mess with source assumption.

p4raw-id: //depot/perlio@8052

toke.c

diff --git a/toke.c b/toke.c
index 232c4ee..5106744 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -13,7 +13,7 @@
 
 /*
  * This file is the lexer for Perl.  It's closely linked to the
- * parser, perly.y.  
+ * parser, perly.y.
  *
  * The main routine is yylex(), which returns the next token.
  */
@@ -39,7 +39,7 @@ static I32 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen);
 /*#define UTF (SvUTF8(PL_linestr) && !(PL_hints & HINT_BYTE))*/
 #define UTF (PL_hints & HINT_UTF8)
 
-/* In variables name $^X, these are the legal values for X.  
+/* 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)))
 
@@ -85,7 +85,7 @@ int yyactlevel = 0;
 #  define yylval (*yylval_pointer[yyactlevel])
 #  define yychar (*yychar_pointer[yyactlevel])
 #  define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]
-#  undef yylex 
+#  undef yylex
 #  define yylex()      Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel])
 #endif
 
@@ -446,7 +446,7 @@ S_incline(pTHX_ char *s)
        return;
     if (*s == ' ' || *s == '\t')
        s++;
-    else 
+    else
        return;
     while (SPACE_OR_TAB(*s)) s++;
     if (!isDIGIT(*s))
@@ -621,8 +621,8 @@ S_check_uni(pTHX)
     if (ckWARN_d(WARN_AMBIGUOUS)){
         char ch = *s;
         *s = '\0';
-        Perl_warner(aTHX_ WARN_AMBIGUOUS, 
-                  "Warning: Use of \"%s\" without parens is ambiguous", 
+        Perl_warner(aTHX_ WARN_AMBIGUOUS,
+                  "Warning: Use of \"%s\" without parens is ambiguous",
                   PL_last_uni);
         *s = ch;
     }
@@ -701,7 +701,7 @@ S_lop(pTHX_ I32 f, int x, char *s)
  * handles the token correctly.
  */
 
-STATIC void 
+STATIC void
 S_force_next(pTHX_ I32 type)
 {
     PL_nexttype[PL_nexttoke] = type;
@@ -734,7 +734,7 @@ S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow
 {
     register char *s;
     STRLEN len;
-    
+
     start = skipspace(start);
     s = start;
     if (isIDFIRST_lazy_if(s,UTF) ||
@@ -815,7 +815,7 @@ Perl_str_to_version(pTHX_ SV *sv)
     return retval;
 }
 
-/* 
+/*
  * S_force_version
  * Forces the next token to be a version number.
  */
@@ -848,7 +848,7 @@ S_force_version(pTHX_ char *s)
 
     /* NOTE: The parser sees the package name and the VERSION swapped */
     PL_nextval[PL_nexttoke].opval = version;
-    force_next(WORD); 
+    force_next(WORD);
 
     return (s);
 }
@@ -956,7 +956,7 @@ S_sublex_start(pTHX)
                SvUTF8_on(nsv);
            SvREFCNT_dec(sv);
            sv = nsv;
-       } 
+       }
        yylval.opval = (OP*)newSVOP(op_type, 0, sv);
        PL_lex_stuff = Nullsv;
        return THING;
@@ -1161,7 +1161,7 @@ S_sublex_done(pTHX)
              } (end switch)
          } (end if backslash)
     } (end while character to read)
-                 
+               
 */
 
 STATIC char *
@@ -1233,11 +1233,11 @@ S_scan_const(pTHX_ char *start)
                dorange = FALSE;
                didrange = TRUE;
                continue;
-           } 
+           }
 
            /* range begins (ignore - as first or last char) */
            else if (*s == '-' && s+1 < send  && s != start) {
-               if (didrange) { 
+               if (didrange) {
                    Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
                }
                if (utf) {
@@ -1272,9 +1272,9 @@ S_scan_const(pTHX_ char *start)
                while (count && (c = *regparse)) {
                    if (c == '\\' && regparse[1])
                        regparse++;
-                   else if (c == '{') 
+                   else if (c == '{')
                        count++;
-                   else if (c == '}') 
+                   else if (c == '}')
                        count--;
                    regparse++;
                }
@@ -1373,7 +1373,7 @@ S_scan_const(pTHX_ char *start)
            default:
                {
                    if (ckWARN(WARN_MISC) && isALNUM(*s))
-                       Perl_warner(aTHX_ WARN_MISC, 
+                       Perl_warner(aTHX_ WARN_MISC,
                               "Unrecognized escape \\%c passed through",
                               *s);
                    /* default action is to copy the quoted character */
@@ -1455,7 +1455,7 @@ S_scan_const(pTHX_ char *start)
 
                     if (has_utf8 || uv > 255) {
                        d = (char*)uv_to_utf8((U8*)d, uv);
-                       this_utf8 = TRUE;
+                       has_utf8 = TRUE;
                     }
                    else {
                        *d++ = (char)uv;
@@ -1474,14 +1474,14 @@ S_scan_const(pTHX_ char *start)
                    SV *res;
                    STRLEN len;
                    char *str;
+
                    if (!e) {
                        yyerror("Missing right brace on \\N{}");
                        e = s - 1;
                        goto cont_scan;
                    }
                    res = newSVpvn(s + 1, e - s - 1);
-                   res = new_constant( Nullch, 0, "charnames", 
+                   res = new_constant( Nullch, 0, "charnames",
                                        res, Nullsv, "\\N{...}" );
                    str = SvPV(res,len);
                    if (!has_utf8 && SvUTF8(res)) {
@@ -1518,7 +1518,7 @@ S_scan_const(pTHX_ char *start)
                *d = *s++;
                if (isLOWER(*d))
                   *d = toUPPER(*d);
-               *d = toCTRL(*d); 
+               *d = toCTRL(*d);
                d++;
 #else
                {
@@ -1584,9 +1584,9 @@ S_scan_const(pTHX_ char *start)
     /* return the substring (via yylval) only if we parsed anything */
     if (s > PL_bufptr) {
        if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
-           sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"), 
+           sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
                              sv, Nullsv,
-                             ( PL_lex_inwhat == OP_TRANS 
+                             ( PL_lex_inwhat == OP_TRANS
                                ? "tr"
                                : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
                                    ? "s"
@@ -1857,7 +1857,7 @@ S_incl_perldb(pTHX)
 
 
 /* Encoded script support. filter_add() effectively inserts a
- * 'pre-processing' function into the current source input stream. 
+ * 'pre-processing' function into the current source input stream.
  * Note that the filter function only applies to the current source file
  * (e.g., it will not affect files 'require'd or 'use'd by this one).
  *
@@ -1893,7 +1893,7 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
     av_store(PL_rsfp_filters, 0, datasv) ;
     return(datasv);
 }
+
 
 /* Delete most recently added instance of this filter function.        */
 void
@@ -1920,8 +1920,8 @@ Perl_filter_del(pTHX_ filter_t funcp)
 /* Invoke the n'th filter function for the current rsfp.        */
 I32
 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
-            
-               
+
+
                                /* 0 = read one text line */
 {
     filter_t funcp;
@@ -1934,7 +1934,7 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
        /* Note that we append to the line. This is handy.      */
        DEBUG_P(PerlIO_printf(Perl_debug_log,
                              "filter_read %d: from rsfp\n", idx));
-       if (maxlen) { 
+       if (maxlen) {
            /* Want a block */
            int len ;
            int old_len = SvCUR(buf_sv) ;
@@ -2130,7 +2130,7 @@ Perl_yylex(pTHX)
            }
        }
 
-       /* 
+       /*
           build the ops for accesses to a my() variable.
 
           Deny my($a) or my($b) in a sort block, *if* $a or $b is
@@ -2448,7 +2448,7 @@ Perl_yylex(pTHX)
            PL_last_lop = 0;
            if (PL_lex_brackets)
                yyerror("Missing right curly or square bracket");
-            DEBUG_T( { PerlIO_printf(Perl_debug_log, 
+            DEBUG_T( { PerlIO_printf(Perl_debug_log,
                         "### Tokener got EOF\n");
             } )
            TOKEN(0);
@@ -2581,7 +2581,7 @@ Perl_yylex(pTHX)
                    PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
                    PL_doextract = FALSE;
                }
-           } 
+           }
            incline(s);
        } while (PL_doextract);
        PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
@@ -2754,7 +2754,7 @@ Perl_yylex(pTHX)
     case '\r':
 #ifdef PERL_STRICT_CR
        Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
-       Perl_croak(aTHX_ 
+       Perl_croak(aTHX_
       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
 #endif
     case ' ': case '\t': case '\f': case 013:
@@ -2801,7 +2801,7 @@ Perl_yylex(pTHX)
 
            if (strnEQ(s,"=>",2)) {
                s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
-                DEBUG_T( { PerlIO_printf(Perl_debug_log, 
+                DEBUG_T( { PerlIO_printf(Perl_debug_log,
                             "### Saw unary minus before =>, forcing word '%s'\n", s);
                 } )
                OPERATOR('-');          /* unary minus */
@@ -2846,7 +2846,7 @@ Perl_yylex(pTHX)
            }
            if (ftst) {
                PL_last_lop_op = ftst;
-               DEBUG_T( { PerlIO_printf(Perl_debug_log, 
+               DEBUG_T( { PerlIO_printf(Perl_debug_log,
                         "### Saw file test %c\n", ftst);
                } )
                if (*s == '(' && ckWARN(WARN_AMBIGUOUS))
@@ -3557,8 +3557,8 @@ Perl_yylex(pTHX)
     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 
+           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();
@@ -3603,7 +3603,7 @@ Perl_yylex(pTHX)
     case '0': case '1': case '2': case '3': case '4':
     case '5': case '6': case '7': case '8': case '9':
        s = scan_num(s, &yylval);
-        DEBUG_T( { PerlIO_printf(Perl_debug_log, 
+        DEBUG_T( { PerlIO_printf(Perl_debug_log,
                     "### Saw number in '%s'\n", s);
         } )
        if (PL_expect == XOPERATOR)
@@ -3612,7 +3612,7 @@ Perl_yylex(pTHX)
 
     case '\'':
        s = scan_str(s,FALSE,FALSE);
-        DEBUG_T( { PerlIO_printf(Perl_debug_log, 
+        DEBUG_T( { PerlIO_printf(Perl_debug_log,
                     "### Saw string in '%s'\n", s);
         } )
        if (PL_expect == XOPERATOR) {
@@ -3631,7 +3631,7 @@ Perl_yylex(pTHX)
 
     case '"':
        s = scan_str(s,FALSE,FALSE);
-        DEBUG_T( { PerlIO_printf(Perl_debug_log, 
+        DEBUG_T( { PerlIO_printf(Perl_debug_log,
                     "### Saw string in '%s'\n", s);
         } )
        if (PL_expect == XOPERATOR) {
@@ -3656,7 +3656,7 @@ Perl_yylex(pTHX)
 
     case '`':
        s = scan_str(s,FALSE,FALSE);
-        DEBUG_T( { PerlIO_printf(Perl_debug_log, 
+        DEBUG_T( { PerlIO_printf(Perl_debug_log,
                     "### Saw backtick string in '%s'\n", s);
         } )
        if (PL_expect == XOPERATOR)
@@ -3858,7 +3858,7 @@ Perl_yylex(pTHX)
                    PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
                {
                    if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
-                       Perl_warner(aTHX_ WARN_BAREWORD, 
+                       Perl_warner(aTHX_ WARN_BAREWORD,
                            "Bareword \"%s\" refers to nonexistent package",
                             PL_tokenbuf);
                    len -= 2;
@@ -4254,7 +4254,7 @@ Perl_yylex(pTHX)
 
        case KEY_exists:
            UNI(OP_EXISTS);
-           
+       
        case KEY_exit:
            UNI(OP_EXIT);
 
@@ -4458,7 +4458,7 @@ Perl_yylex(pTHX)
        case KEY_last:
            s = force_word(s,WORD,TRUE,FALSE,FALSE);
            LOOPX(OP_LAST);
-           
+       
        case KEY_lc:
            UNI(OP_LC);
 
@@ -4603,7 +4603,7 @@ Perl_yylex(pTHX)
 
        case KEY_pos:
            UNI(OP_POS);
-           
+       
        case KEY_pack:
            LOP(OP_PACK,XTERM);
 
@@ -4765,7 +4765,7 @@ Perl_yylex(pTHX)
 
        case KEY_chomp:
            UNI(OP_CHOMP);
-           
+       
        case KEY_scalar:
            UNI(OP_SCALAR);
 
@@ -5054,7 +5054,7 @@ Perl_yylex(pTHX)
        case KEY_umask:
            if (ckWARN(WARN_UMASK)) {
                for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
-               if (*d != '0' && isDIGIT(*d)) 
+               if (*d != '0' && isDIGIT(*d))
                    Perl_warner(aTHX_ WARN_UMASK,
                                "umask: argument is missing initial 0");
            }
@@ -5109,7 +5109,7 @@ Perl_yylex(pTHX)
        {
            static char ctl_l[2];
 
-           if (ctl_l[0] == '\0') 
+           if (ctl_l[0] == '\0')
                ctl_l[0] = toCTRL('L');
            gv_fetchpv(ctl_l,TRUE, SVt_PV);
        }
@@ -5481,7 +5481,7 @@ Perl_keyword(pTHX_ register char *d, I32 len)
     case 'p':
        switch (len) {
        case 3:
-           if (strEQ(d,"pop"))                 return -KEY_pop; 
+           if (strEQ(d,"pop"))                 return -KEY_pop;
            if (strEQ(d,"pos"))                 return KEY_pos;
            break;
        case 4:
@@ -5801,14 +5801,14 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
     SV **cvp;
     SV *cv, *typesv;
     const char *why1, *why2, *why3;
-    
+
     if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
        SV *msg;
        
        why2 = strEQ(key,"charnames")
               ? "(possibly a missing \"use charnames ...\")"
               : "";
-       msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s", 
+       msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
                            (type ? type: "undef"), why2);
 
        /* This is convoluted and evil ("goto considered harmful")
@@ -5819,7 +5819,7 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
        goto msgdone;
 
     report:
-       msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s", 
+       msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
                            (type ? type: "undef"), why1, why2, why3);
     msgdone:
        yyerror(SvPVX(msg));
@@ -5841,11 +5841,11 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
        typesv = sv_2mortal(newSVpv(type, 0));
     else
        typesv = &PL_sv_undef;
-    
+
     PUSHSTACKi(PERLSI_OVERLOAD);
     ENTER ;
     SAVETMPS;
-    
+
     PUSHMARK(SP) ;
     EXTEND(sp, 3);
     if (pv)
@@ -5855,9 +5855,9 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
        PUSHs(typesv);
     PUTBACK;
     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
-    
+
     SPAGAIN ;
-    
+
     /* Check the eval first */
     if (!PL_in_eval && SvTRUE(ERRSV)) {
        STRLEN n_a;
@@ -5870,12 +5870,12 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
        res = POPs;
        (void)SvREFCNT_inc(res);
     }
-    
+
     PUTBACK ;
     FREETMPS ;
     LEAVE ;
     POPSTACK;
-    
+
     if (!SvOK(res)) {
        why1 = "Call to &{$^H{";
        why2 = key;
@@ -5886,7 +5886,7 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
 
     return res;
 }
-  
+
 STATIC char *
 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
 {
@@ -6039,8 +6039,8 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des
                PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
                return s;
            }
-       } 
-       /* Handle extended ${^Foo} variables 
+       }
+       /* Handle extended ${^Foo} variables
         * 1999-02-27 mjd-perl-patch@plover.com */
        else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
                 && isALNUM(*s))
@@ -6592,7 +6592,7 @@ S_scan_inputsymbol(pTHX_ char *start)
    calls scan_str().  s/// makes yylex() call scan_subst() which calls
    scan_str().  tr/// and y/// make yylex() call scan_trans() which
    calls scan_str().
-      
+
    It skips whitespace before the string starts, and treats the first
    character as the delimiter.  If the delimiter is one of ([{< then
    the corresponding "close" character )]}> is used as the closing
@@ -6758,7 +6758,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
        /* having changed the buffer, we must update PL_bufend */
        PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
     }
-    
+
     /* at this point, we have successfully read the delimited string */
 
     if (keep_delims)
@@ -6777,7 +6777,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
     /* decide whether this is the first or second quoted string we've read
        for this op
     */
-    
+
     if (PL_lex_stuff)
        PL_lex_repl = sv;
     else
@@ -6806,7 +6806,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
   try converting the number to an integer and see if it can do so
   without loss of precision.
 */
-  
+
 char *
 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
 {
@@ -6824,7 +6824,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
     switch (*s) {
     default:
       Perl_croak(aTHX_ "panic: scan_num");
-      
+
     /* if it starts with a 0, it could be an octal number, a decimal in
        0.13 disguise, or a hexadecimal number, or a binary number. */
     case '0':
@@ -6990,7 +6990,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
 
        /* read next group of digits and _ and copy into d */
        while (isDIGIT(*s) || *s == '_') {
-           /* skip underscores, checking for misplaced ones 
+           /* skip underscores, checking for misplaced ones
               if -w is on
            */
            if (*s == '_') {
@@ -7117,7 +7117,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
           compilers have issues.  Then we try casting it back and see
           if it was the same [1].  We only do this if we know we
           specifically read an integer.  If floatit is true, then we
-          don't need to do the conversion at all. 
+          don't need to do the conversion at all.
 
           [1] Note that this is lossy if our NVs cannot preserve our
           UVs.  There are metaconfig defines NV_PRESERVES_UV (a boolean)
@@ -7128,7 +7128,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
           Maybe could do some tricks with DBL_DIG, LDBL_DIG and
           DBL_MANT_DIG and LDBL_MANT_DIG (these are already available
           as NV_DIG and NV_MANT_DIG)?
-          
+       
           --jhi
           */
        {
@@ -7145,7 +7145,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
 #endif
        if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
                       (PL_hints & HINT_NEW_INTEGER) )
-           sv = new_constant(PL_tokenbuf, d - PL_tokenbuf, 
+           sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
                              (floatit ? "float" : "integer"),
                              sv, Nullsv, NULL);
        break;
@@ -7462,8 +7462,8 @@ S_swallow_bom(pTHX_ U8 *s)
     STRLEN slen;
     slen = SvCUR(PL_linestr);
     switch (*s) {
-    case 0xFF:       
-       if (s[1] == 0xFE) { 
+    case 0xFF:
+       if (s[1] == 0xFE) {
            /* UTF-16 little-endian */
            if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
                Perl_croak(aTHX_ "Unsupported script encoding");
@@ -7565,7 +7565,7 @@ utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
        if (!*SvPV_nolen(sv))
        /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
        return count;
-       
+
        tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
        sv_usepvn(sv, (char*)tmps, tend - tmps);
     }