fix bogus OPf_REF context for the BLOCK in C<grep BLOCK @foo>

[perl5.git] / op.c

diff --git a/op.c b/op.c
index 51df803..d5af3c9 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1,6 +1,6 @@
 /*    op.c
  *
- *    Copyright (c) 1991-1997, Larry Wall
+ *    Copyright (c) 1991-1999, 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.
@@ -48,7 +48,7 @@ static OP *too_few_arguments _((OP *o, char* name));
 static OP *too_many_arguments _((OP *o, char* name));
 static void null _((OP* o));
 static PADOFFSET pad_findlex _((char* name, PADOFFSET newoff, U32 seq,
-       CV* startcv, I32 cx_ix, I32 saweval));
+       CV* startcv, I32 cx_ix, I32 saweval, U32 flags));
 static OP *newDEFSVOP _((void));
 static OP *new_logop _((I32 type, I32 flags, OP **firstp, OP **otherp));
 static void simplify_sort _((OP *o));
@@ -129,11 +129,25 @@ pad_allocmy(char *name)
        name[1] == '_' && (int)strlen(name) > 2))
     {
        if (!isPRINT(name[1])) {
-           name[3] = '\0';
+           /* 1999-02-27 mjd@plover.com */
+           char *p;
+           p = strchr(name, '\0');
+           /* The next block assumes the buffer is at least 205 chars
+              long.  At present, it's always at least 256 chars. */
+           if (p-name > 200) {
+               strcpy(name+200, "...");
+               p = name+199;
+           }
+           else {
+               p[1] = '\0';
+           }
+           /* Move everything else down one character */
+           for (; p-name > 2; p--)
+               *p = *(p-1);
            name[2] = toCTRL(name[1]);
            name[1] = '^';
        }
-       croak("Can't use global %s in \"my\"",name);
+       yyerror(form("Can't use global %s in \"my\"",name));
     }
     if (ckWARN(WARN_UNSAFE) && AvFILLp(PL_comppad_name) >= 0) {
        SV **svp = AvARRAY(PL_comppad_name);
@@ -156,7 +170,8 @@ pad_allocmy(char *name)
     sv_setpv(sv, name);
     if (PL_in_my_stash) {
        if (*name != '$')
-           croak("Can't declare class for non-scalar %s in \"my\"",name);
+           yyerror(form("Can't declare class for non-scalar %s in \"my\"",
+                        name));
        SvOBJECT_on(sv);
        (void)SvUPGRADE(sv, SVt_PVMG);
        SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
@@ -176,8 +191,11 @@ pad_allocmy(char *name)
     return off;
 }
 
+#define FINDLEX_NOSEARCH       1               /* don't search outer contexts */
+
 STATIC PADOFFSET
-pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval)
+pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 saweval,
+           U32 flags)
 {
     dTHR;
     CV *cv;
@@ -272,6 +290,9 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 s
        }
     }
 
+    if (flags & FINDLEX_NOSEARCH)
+       return 0;
+
     /* Nothing in current lexical context--try eval's context, if any.
      * This is necessary to let the perldb get at lexically scoped variables.
      * XXX This will also probably interact badly with eval tree caching.
@@ -283,7 +304,7 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 s
        default:
            if (i == 0 && saweval) {
                seq = cxstack[saweval].blk_oldcop->cop_seq;
-               return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval);
+               return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
            }
            break;
        case CXt_EVAL:
@@ -306,7 +327,7 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix, I32 s
                continue;
            }
            seq = cxstack[saweval].blk_oldcop->cop_seq;
-           return pad_findlex(name, newoff, seq, cv, i-1, saweval);
+           return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
        }
     }
 
@@ -358,15 +379,15 @@ pad_findmy(char *name)
     /* Check if if we're compiling an eval'', and adjust seq to be the
      * eval's seq number.  This depends on eval'' having a non-null
      * CvOUTSIDE() while it is being compiled.  The eval'' itself is
-     * identified by CvUNIQUE being set and CvGV being null. */
-    if (outside && CvUNIQUE(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
+     * identified by CvEVAL being true and CvGV being null. */
+    if (outside && CvEVAL(PL_compcv) && !CvGV(PL_compcv) && cxstack_ix >= 0) {
        cx = &cxstack[cxstack_ix];
        if (CxREALEVAL(cx))
            seq = cx->blk_oldcop->cop_seq;
     }
 
     /* See if it's in a nested scope */
-    off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0);
+    off = pad_findlex(name, 0, seq, outside, cxstack_ix, 0, 0);
     if (off) {
        /* If there is a pending local definition, this new alias must die */
        if (pendoff)
@@ -2485,8 +2506,11 @@ pmruntime(OP *o, OP *expr, OP *repl)
 
     if (repl) {
        OP *curop;
-       if (pm->op_pmflags & PMf_EVAL)
+       if (pm->op_pmflags & PMf_EVAL) {
            curop = 0;
+           if (PL_curcop->cop_line < PL_multi_end)
+               PL_curcop->cop_line = PL_multi_end;
+       }
 #ifdef USE_THREADS
        else if (repl->op_type == OP_THREADSV
                 && strchr("&`'123456789+",
@@ -3666,7 +3690,7 @@ cv_clone2(CV *proto, CV *outside)
            char *name = SvPVX(namesv);    /* XXX */
            if (SvFLAGS(namesv) & SVf_FAKE) {   /* lexical from outside? */
                I32 off = pad_findlex(name, ix, SvIVX(namesv),
-                                     CvOUTSIDE(cv), cxstack_ix, 0);
+                                     CvOUTSIDE(cv), cxstack_ix, 0, 0);
                if (!off)
                    PL_curpad[ix] = SvREFCNT_inc(ppad[ix]);
                else if (off != ix)
@@ -4282,7 +4306,7 @@ newAVREF(OP *o)
 OP *
 newGVREF(I32 type, OP *o)
 {
-    if (type == OP_MAPSTART)
+    if (type == OP_MAPSTART || type == OP_GREPSTART)
        return newUNOP(OP_NULL, 0, o);
     return ref(newUNOP(OP_RV2GV, OPf_REF, o), type);
 }
@@ -5090,7 +5114,7 @@ ck_sort(OP *o)
        o->op_private |= OPpLOCALE;
 #endif
 
-    if (o->op_flags & OPf_STACKED)
+    if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
        simplify_sort(o);
     if (o->op_flags & OPf_STACKED) {                /* may have been cleared */
        OP *kid = cLISTOPo->op_first->op_sibling;       /* get past pushmark */
@@ -5143,6 +5167,8 @@ simplify_sort(OP *o)
     int reversed;
     if (!(o->op_flags & OPf_STACKED))
        return;
+    GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV)); 
+    GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV)); 
     kid = kUNOP->op_first;                             /* get past rv2gv */
     if (kid->op_type != OP_SCOPE)
        return;
@@ -5303,19 +5329,13 @@ ck_subr(OP *o)
                    bad_type(arg, "block", gv_ename(namegv), o2);
                break;
            case '*':
+               /* '*' allows any scalar type, including bareword */
                proto++;
                arg++;
                if (o2->op_type == OP_RV2GV)
-                   goto wrapref;
-               {
-                   OP* kid = o2;
-                   OP* sib = kid->op_sibling;
-                   kid->op_sibling = 0;
-                   o2 = newUNOP(OP_RV2GV, 0, kid);
-                   o2->op_sibling = sib;
-                   prev->op_sibling = o2;
-               }
-               goto wrapref;
+                   goto wrapref;       /* autoconvert GLOB -> GLOBref */
+               scalar(o2);
+               break;
            case '\\':
                proto++;
                arg++;