Allow regexp.t to take a command line argument for the filename of
[p5sagit/p5-mst-13.2.git] / toke.c
diff --git a/toke.c b/toke.c
index 4d5d9c2..e34f796 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -735,13 +735,12 @@ Perl_lex_end(pTHX)
  */
 
 STATIC void
-S_incline(pTHX_ char *s)
+S_incline(pTHX_ const char *s)
 {
     dVAR;
-    char *t;
-    char *n;
-    char *e;
-    char ch;
+    const char *t;
+    const char *n;
+    const char *e;
 
     CopLINE_inc(PL_curcop);
     if (*s++ != '#')
@@ -781,34 +780,48 @@ S_incline(pTHX_ char *s)
     if (*e != '\n' && *e != '\0')
        return;         /* false alarm */
 
-    ch = *t;
-    *t = '\0';
     if (t - s > 0) {
+       const STRLEN len = t - s;
 #ifndef USE_ITHREADS
        const char * const cf = CopFILE(PL_curcop);
        STRLEN tmplen = cf ? strlen(cf) : 0;
        if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
            /* must copy *{"::_<(eval N)[oldfilename:L]"}
             * to *{"::_<newfilename"} */
-           char smallbuf[256], smallbuf2[256];
-           char *tmpbuf, *tmpbuf2;
-           GV **gvp, *gv2;
-           STRLEN tmplen2 = strlen(s);
-           if (tmplen + 3 < sizeof smallbuf)
+           /* However, the long form of evals is only turned on by the
+              debugger - usually they're "(eval %lu)" */
+           char smallbuf[128];
+           char *tmpbuf;
+           GV **gvp;
+           STRLEN tmplen2 = len;
+           if (tmplen + 2 <= sizeof smallbuf)
                tmpbuf = smallbuf;
            else
-               Newx(tmpbuf, tmplen + 3, char);
-           if (tmplen2 + 3 < sizeof smallbuf2)
-               tmpbuf2 = smallbuf2;
-           else
-               Newx(tmpbuf2, tmplen2 + 3, char);
-           tmpbuf[0] = tmpbuf2[0] = '_';
-           tmpbuf[1] = tmpbuf2[1] = '<';
-           memcpy(tmpbuf + 2, cf, ++tmplen);
-           memcpy(tmpbuf2 + 2, s, ++tmplen2);
-           ++tmplen; ++tmplen2;
+               Newx(tmpbuf, tmplen + 2, char);
+           tmpbuf[0] = '_';
+           tmpbuf[1] = '<';
+           memcpy(tmpbuf + 2, cf, tmplen);
+           tmplen += 2;
            gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
            if (gvp) {
+               char *tmpbuf2;
+               GV *gv2;
+
+               if (tmplen2 + 2 <= sizeof smallbuf)
+                   tmpbuf2 = smallbuf;
+               else
+                   Newx(tmpbuf2, tmplen2 + 2, char);
+
+               if (tmpbuf2 != smallbuf || tmpbuf != smallbuf) {
+                   /* Either they malloc'd it, or we malloc'd it,
+                      so no prefix is present in ours.  */
+                   tmpbuf2[0] = '_';
+                   tmpbuf2[1] = '<';
+               }
+
+               memcpy(tmpbuf2 + 2, s, tmplen2);
+               tmplen2 += 2;
+
                gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
                if (!isGV(gv2)) {
                    gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
@@ -817,15 +830,15 @@ S_incline(pTHX_ char *s)
                    GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
                    GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
                }
+
+               if (tmpbuf2 != smallbuf) Safefree(tmpbuf2);
            }
            if (tmpbuf != smallbuf) Safefree(tmpbuf);
-           if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
        }
 #endif
        CopFILE_free(PL_curcop);
-       CopFILE_set(PL_curcop, s);
+       CopFILE_setn(PL_curcop, s, len);
     }
-    *t = ch;
     CopLINE_set(PL_curcop, atoi(n)-1);
 }
 
@@ -2659,7 +2672,7 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
        if (indirgv && GvCVu(indirgv))
            return 0;
        /* filehandle or package name makes it a method */
-       if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
+       if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, 0)) {
 #ifdef PERL_MAD
            soff = s - SvPVX(PL_linestr);
 #endif
@@ -2891,7 +2904,7 @@ S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
             pkgname = SvPV_nolen_const(sv);
     }
 
-    return gv_stashpv(pkgname, FALSE);
+    return gv_stashpv(pkgname, 0);
 }
 
 /*
@@ -3674,7 +3687,7 @@ Perl_yylex(pTHX)
                if (PL_madskills)
                    sv_catsv(PL_thiswhite, PL_linestr);
 #endif
-               if (*s == '=' && strnEQ(s, "=cut", 4)) {
+               if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) {
                    sv_setpvn(PL_linestr, "", 0);
                    PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
                    PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
@@ -4134,8 +4147,7 @@ Perl_yylex(pTHX)
        /* FALL THROUGH */
     case '~':
        if (s[1] == '~'
-       && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)
-       && FEATURE_IS_ENABLED("~~"))
+           && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR))
        {
            s += 2;
            Eop(OP_SMARTMATCH);
@@ -4795,12 +4807,12 @@ Perl_yylex(pTHX)
                                t++;
                            } while (isSPACE(*t));
                            if (isIDFIRST_lazy_if(t,UTF)) {
-                               STRLEN dummylen;
+                               STRLEN len;
                                t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
-                                             &dummylen);
+                                             &len);
                                while (isSPACE(*t))
                                    t++;
-                               if (*t == ';' && get_cv(tmpbuf, FALSE))
+                               if (*t == ';' && get_cvn_flags(tmpbuf, len, 0))
                                    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
                                                "You need to quote \"%s\"",
                                                tmpbuf);
@@ -5521,7 +5533,7 @@ Perl_yylex(pTHX)
                        }
                    }
                    if (probable_sub) {
-                       gv = gv_fetchpv(PL_tokenbuf, TRUE, SVt_PVCV);
+                       gv = gv_fetchpv(PL_tokenbuf, GV_ADD, SVt_PVCV);
                        op_free(yylval.opval);
                        yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
                        yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
@@ -5557,7 +5569,7 @@ Perl_yylex(pTHX)
                            d = PL_tokenbuf;
                            while (isLOWER(*d))
                                d++;
-                           if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
+                           if (!*d && !gv_stashpv(PL_tokenbuf, 0))
                                Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
                                       PL_tokenbuf);
                        }
@@ -6355,7 +6367,7 @@ Perl_yylex(pTHX)
                *PL_tokenbuf = '\0';
                s = force_word(s,WORD,TRUE,TRUE,FALSE);
                if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
-                   gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
+                   gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), GV_ADD);
                else if (*s == '<')
                    yyerror("<> should be quotes");
            }
@@ -10738,7 +10750,8 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL
            }
            if (PL_lex_state == LEX_NORMAL) {
                if (ckWARN(WARN_AMBIGUOUS) &&
-                   (keyword(dest, d - dest, 0) || get_cv(dest, FALSE)))
+                   (keyword(dest, d - dest, 0)
+                    || get_cvn_flags(dest, d - dest, 0)))
                {
                    if (funny == '#')
                        funny = '@';
@@ -10762,20 +10775,16 @@ void
 Perl_pmflag(pTHX_ U32* pmfl, int ch)
 {
     PERL_UNUSED_CONTEXT;
-    if (ch == 'i')
-       *pmfl |= PMf_FOLD;
-    else if (ch == 'g')
-       *pmfl |= PMf_GLOBAL;
-    else if (ch == 'c')
-       *pmfl |= PMf_CONTINUE;
-    else if (ch == 'o')
-       *pmfl |= PMf_KEEP;
-    else if (ch == 'm')
-       *pmfl |= PMf_MULTILINE;
-    else if (ch == 's')
-       *pmfl |= PMf_SINGLELINE;
-    else if (ch == 'x')
-       *pmfl |= PMf_EXTENDED;
+    if (ch<256) {
+        char c = (char)ch;
+        switch (c) {
+            CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl);
+            case GLOBAL_PAT_MOD:    *pmfl |= PMf_GLOBAL; break;
+            case CONTINUE_PAT_MOD:  *pmfl |= PMf_CONTINUE; break;
+            case ONCE_PAT_MOD:      *pmfl |= PMf_KEEP; break;
+            case KEEPCOPY_PAT_MOD:  *pmfl |= PMf_KEEPCOPY; break;
+        }
+    }
 }
 
 STATIC char *
@@ -10785,7 +10794,7 @@ S_scan_pat(pTHX_ char *start, I32 type)
     PMOP *pm;
     char *s = scan_str(start,!!PL_madskills,FALSE);
     const char * const valid_flags =
-       (const char *)((type == OP_QR) ? "iomsx" : "iogcmsx");
+       (const char *)((type == OP_QR) ? QR_PAT_MODS : M_PAT_MODS);
 #ifdef PERL_MAD
     char *modstart;
 #endif
@@ -10818,7 +10827,8 @@ S_scan_pat(pTHX_ char *start, I32 type)
     if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
            && ckWARN(WARN_REGEXP))
     {
-        Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" );
+        Perl_warner(aTHX_ packWARN(WARN_REGEXP), 
+            "Use of /c modifier is meaningless without /g" );
     }
 
     pm->op_pmpermflags = pm->op_pmflags;
@@ -10882,11 +10892,11 @@ S_scan_subst(pTHX_ char *start)
 #endif
 
     while (*s) {
-       if (*s == 'e') {
+       if (*s == EXEC_PAT_MOD) {
            s++;
            es++;
        }
-       else if (strchr("iogcmsx", *s))
+       else if (strchr(S_PAT_MODS, *s))
            pmflag(&pm->op_pmflags,*s++);
        else
            break;
@@ -10997,7 +11007,7 @@ S_scan_trans(pTHX_ char *start)
     }
   no_more:
 
-    tbl = PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
+    tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
     o = newPVOP(OP_TRANS, 0, (char*)tbl);
     o->op_private &= ~OPpTRANS_ALL;
     o->op_private |= del|squash|complement|