Wrong test.

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

diff --git a/toke.c b/toke.c
index 901ebd9..b0a5f5a 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -1,6 +1,6 @@
 /*    toke.c
  *
- *    Copyright (c) 1991-2001, Larry Wall
+ *    Copyright (c) 1991-2002, 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.
@@ -319,6 +319,22 @@ Perl_deprecate(pTHX_ char *s)
        Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
 }
 
+void
+Perl_deprecate_old(pTHX_ char *s)
+{
+    /* This function should NOT be called for any new deprecated warnings */
+    /* Use Perl_deprecate instead                                         */
+    /*                                                                    */
+    /* It is here to maintain backward compatibility with the pre-5.8     */
+    /* warnings category hierarchy. The "deprecated" category used to     */
+    /* live under the "syntax" category. It is now a top-level category   */
+    /* in its own right.                                                  */
+
+    if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
+       Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), 
+                       "Use of %s is deprecated", s);
+}
+
 /*
  * depcom
  * Deprecate a comma-less variable list.
@@ -327,7 +343,7 @@ Perl_deprecate(pTHX_ char *s)
 STATIC void
 S_depcom(pTHX)
 {
-    deprecate("comma-less variable list");
+    deprecate_old("comma-less variable list");
 }
 
 /*
@@ -1424,7 +1440,9 @@ S_scan_const(pTHX_ char *start)
                /* FALL THROUGH */
            default:
                {
-                   if (ckWARN(WARN_MISC) && isALNUM(*s))
+                   if (ckWARN(WARN_MISC) &&
+                       isALNUM(*s) && 
+                       *s != '_')
                        Perl_warner(aTHX_ WARN_MISC,
                               "Unrecognized escape \\%c passed through",
                               *s);
@@ -1555,6 +1573,26 @@ S_scan_const(pTHX_ char *start)
                    if (has_utf8)
                        sv_utf8_upgrade(res);
                    str = SvPV(res,len);
+#ifdef EBCDIC_NEVER_MIND
+                   /* charnames uses pack U and that has been
+                    * recently changed to do the below uni->native
+                    * mapping, so this would be redundant (and wrong,
+                    * the code point would be doubly converted).
+                    * But leave this in just in case the pack U change
+                    * gets revoked, but the semantics is still
+                    * desireable for charnames. --jhi */
+                   {
+                        UV uv = utf8_to_uvchr((U8*)str, 0);
+
+                        if (uv < 0x100) {
+                             U8 tmpbuf[UTF8_MAXLEN+1], *d;
+
+                             d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
+                             sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
+                             str = SvPV(res, len);
+                        }
+                   }
+#endif
                    if (!has_utf8 && SvUTF8(res)) {
                        char *ostart = SvPVX(sv);
                        SvCUR_set(sv, d - ostart);
@@ -1652,7 +1690,7 @@ S_scan_const(pTHX_ char *start)
 
     SvPOK_on(sv);
     if (PL_encoding && !has_utf8) {
-        Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding);
+        sv_recode_to_utf8(sv, PL_encoding);
         has_utf8 = TRUE;
     }
     if (has_utf8) {
@@ -2180,7 +2218,7 @@ Perl_yylex(pTHX)
     bool bof = FALSE;
 
     /* check if there's an identifier for us to look at */
-    if (PL_pending_ident) 
+    if (PL_pending_ident)
         return S_pending_ident(aTHX);
 
     /* no identifier pending identification */
@@ -4005,7 +4043,8 @@ Perl_yylex(pTHX)
                        if (strEQ(proto, "$"))
                            OPERATOR(UNIOPSUB);
                        if (*proto == '&' && *s == '{') {
-                           sv_setpv(PL_subname,"__ANON__");
+                           sv_setpv(PL_subname, PL_curstash ? 
+                                       "__ANON__" : "__ANON__::__ANON__");
                            PREBLOCK(LSTOPSUB);
                        }
                    }
@@ -4986,7 +5025,8 @@ Perl_yylex(pTHX)
                    force_next(THING);
                }
                if (!have_name) {
-                   sv_setpv(PL_subname,"__ANON__");
+                   sv_setpv(PL_subname,
+                       PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
                    TOKEN(ANONSUB);
                }
                (void) force_word(PL_oldbufptr + tboffset, WORD,
@@ -6421,7 +6461,7 @@ S_scan_heredoc(pTHX_ register char *s)
        else
            term = '"';
        if (!isALNUM_lazy_if(s,UTF))
-           deprecate("bare << to mean <<\"\"");
+           deprecate_old("bare << to mean <<\"\"");
        for (; isALNUM_lazy_if(s,UTF); s++) {
            if (d < e)
                *d++ = *s;
@@ -6668,12 +6708,12 @@ S_scan_inputsymbol(pTHX_ char *start)
            (void)strcpy(d,"ARGV");
 
        /* Check whether readline() is overriden */
-       if ((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
-               && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)
+       if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
+               && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
                ||
-               (gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
+               ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
                && (gv_readline = *gvp) != (GV*)&PL_sv_undef
-               && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
+               && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
            readline_overriden = TRUE;
 
        /* if <$fh>, create the ops to turn the variable into a
@@ -6722,7 +6762,8 @@ intro_sym:
                            newUNOP(OP_RV2SV, 0,
                                newGVOP(OP_GV, 0, gv)));
            }
-           PL_lex_op->op_flags |= OPf_SPECIAL;
+           if (!readline_overriden)
+               PL_lex_op->op_flags |= OPf_SPECIAL;
            /* we created the ops in PL_lex_op, so make yylval.ival a null op */
            yylval.ival = OP_NULL;
        }
@@ -7579,7 +7620,7 @@ Perl_yyerror(pTHX_ char *s)
     }
     msg = sv_2mortal(newSVpv(s, 0));
     Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
-                  CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
+        OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
     if (context)
        Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
     else
@@ -7597,10 +7638,10 @@ Perl_yyerror(pTHX_ char *s)
     if (PL_error_count >= 10) {
        if (PL_in_eval && SvCUR(ERRSV))
            Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
-                      ERRSV, CopFILE(PL_curcop));
+            ERRSV, OutCopFILE(PL_curcop));
        else
            Perl_croak(aTHX_ "%s has too many errors.\n",
-                      CopFILE(PL_curcop));
+            OutCopFILE(PL_curcop));
     }
     PL_in_my = 0;
     PL_in_my_stash = Nullhv;