Remove warnings against WHOA THERE warnings from the hints files.

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

diff --git a/toke.c b/toke.c
index 4158e32..d61063a 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -662,13 +662,11 @@ Perl_lex_start(pTHX_ SV *line)
     PL_lex_inwhat = 0;
     PL_sublex_info.sub_inwhat = 0;
     PL_linestr = line;
-    if (SvREADONLY(PL_linestr))
-       PL_linestr = sv_2mortal(newSVsv(PL_linestr));
     s = SvPV_const(PL_linestr, len);
-    if (!len || s[len-1] != ';') {
-       if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
-           PL_linestr = sv_2mortal(newSVsv(PL_linestr));
-       sv_catpvs(PL_linestr, "\n;");
+    if (SvREADONLY(PL_linestr) || !len || s[len-1] != ';') {
+       PL_linestr = sv_2mortal(len ? newSVsv(PL_linestr) : newSVpvn(s, 0));
+       if (!len || s[len-1] != ';')
+           sv_catpvs(PL_linestr, "\n;");
     }
     SvTEMP_off(PL_linestr);
     PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
@@ -776,12 +774,13 @@ S_incline(pTHX_ char *s)
            gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
            if (gvp) {
                gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
-               if (!isGV(gv2))
+               if (!isGV(gv2)) {
                    gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
-               /* adjust ${"::_<newfilename"} to store the new file name */
-               GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
-               GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
-               GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
+                   /* adjust ${"::_<newfilename"} to store the new file name */
+                   GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
+                   GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
+                   GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
+               }
            }
            if (tmpbuf != smallbuf) Safefree(tmpbuf);
            if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
@@ -1541,6 +1540,14 @@ S_sublex_start(pTHX)
            PL_expect = XTERMORDORDOR;
        return THING;
     }
+    else if (op_type == OP_BACKTICK && PL_lex_op) {
+       /* readpipe() vas overriden */
+       cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
+       yylval.opval = PL_lex_op;
+       PL_lex_op = NULL;
+       PL_lex_stuff = NULL;
+       return THING;
+    }
 
     PL_sublex_info.super_state = PL_lex_state;
     PL_sublex_info.sub_inwhat = op_type;
@@ -2840,6 +2847,34 @@ S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
     return gv_stashpv(pkgname, FALSE);
 }
 
+/*
+ * S_readpipe_override
+ * Check whether readpipe() is overriden, and generates the appropriate
+ * optree, provided sublex_start() is called afterwards.
+ */
+STATIC void
+S_readpipe_override(pTHX)
+{
+    GV **gvp;
+    GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
+    yylval.ival = OP_BACKTICK;
+    if ((gv_readpipe
+               && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
+           ||
+           ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
+            && (gv_readpipe = *gvp) != (GV*)&PL_sv_undef
+            && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
+    {
+       PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
+           append_elem(OP_LIST,
+               newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
+               newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
+    }
+    else {
+       set_csh();
+    }
+}
+
 #ifdef PERL_MAD 
  /*
  * Perl_madlex
@@ -4951,8 +4986,7 @@ Perl_yylex(pTHX)
            no_op("Backticks",s);
        if (!s)
            missingterm(NULL);
-       yylval.ival = OP_BACKTICK;
-       set_csh();
+       readpipe_override();
        TERM(sublex_start());
 
     case '\\':
@@ -5630,6 +5664,7 @@ Perl_yylex(pTHX)
        case KEY_AUTOLOAD:
        case KEY_DESTROY:
        case KEY_BEGIN:
+       case KEY_UNITCHECK:
        case KEY_CHECK:
        case KEY_INIT:
        case KEY_END:
@@ -6270,8 +6305,7 @@ Perl_yylex(pTHX)
            s = scan_str(s,!!PL_madskills,FALSE);
            if (!s)
                missingterm(NULL);
-           yylval.ival = OP_BACKTICK;
-           set_csh();
+           readpipe_override();
            TERM(sublex_start());
 
        case KEY_return:
@@ -7358,7 +7392,7 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
             case 'a':
               if (name[2] == 'y')
               {                                   /* say        */
-                return (all_keywords || FEATURE_IS_ENABLED("say") ? -KEY_say : 0);
+                return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
               }
 
               goto unknown;
@@ -9683,9 +9717,24 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
           goto unknown;
       }
 
-    case 9: /* 8 tokens of length 9 */
+    case 9: /* 9 tokens of length 9 */
       switch (name[0])
       {
+        case 'U':
+          if (name[1] == 'N' &&
+              name[2] == 'I' &&
+              name[3] == 'T' &&
+              name[4] == 'C' &&
+              name[5] == 'H' &&
+              name[6] == 'E' &&
+              name[7] == 'C' &&
+              name[8] == 'K')
+          {                                       /* UNITCHECK  */
+            return KEY_UNITCHECK;
+          }
+
+          goto unknown;
+
         case 'e':
           if (name[1] == 'n' &&
               name[2] == 'd' &&
@@ -11423,7 +11472,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
     I32 termcode;                      /* terminating char. code */
     U8 termstr[UTF8_MAXBYTES];         /* terminating string */
     STRLEN termlen;                    /* length of terminating string */
-    char *last = NULL;                 /* last position for nesting bracket */
+    int last_off = 0;                  /* last position for nesting bracket */
 #ifdef PERL_MAD
     int stuffstart;
     char *tstart;
@@ -11524,9 +11573,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
                    else {
                        const char *t;
                        char *w;
-                       if (!last)
-                           last = SvPVX(sv);
-                       for (t = w = last; t < svlast; w++, t++) {
+                       for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
                            /* At here, all closes are "was quoted" one,
                               so we don't check PL_multi_close. */
                            if (*t == '\\') {
@@ -11545,7 +11592,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
                            *w = '\0';
                            SvCUR_set(sv, w - SvPVX_const(sv));
                        }
-                       last = w;
+                       last_off = w - SvPVX(sv);
                        if (--brackets <= 0)
                            cont = FALSE;
                    }