perl 5.002_01: vms/myconfig.com
[p5sagit/p5-mst-13.2.git] / pp_hot.c
index 31983f1..8fe39f3 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -76,6 +76,64 @@ PP(pp_gv)
     RETURN;
 }
 
+PP(pp_gelem)
+{
+    GV *gv;
+    SV *sv;
+    SV *ref;
+    char *elem;
+    dSP;
+
+    sv = POPs;
+    elem = SvPV(sv, na);
+    gv = (GV*)POPs;
+    ref = Nullsv;
+    sv = Nullsv;
+    switch (elem ? *elem : '\0')
+    {
+    case 'A':
+       if (strEQ(elem, "ARRAY"))
+           ref = (SV*)GvAV(gv);
+       break;
+    case 'C':
+       if (strEQ(elem, "CODE"))
+           ref = (SV*)GvCV(gv);
+       break;
+    case 'F':
+       if (strEQ(elem, "FILEHANDLE"))
+           ref = (SV*)GvIOp(gv);
+       break;
+    case 'G':
+       if (strEQ(elem, "GLOB"))
+           ref = (SV*)gv;
+       break;
+    case 'H':
+       if (strEQ(elem, "HASH"))
+           ref = (SV*)GvHV(gv);
+       break;
+    case 'N':
+       if (strEQ(elem, "NAME"))
+           sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
+       break;
+    case 'P':
+       if (strEQ(elem, "PACKAGE"))
+           sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
+       break;
+    case 'S':
+       if (strEQ(elem, "SCALAR"))
+           ref = GvSV(gv);
+       break;
+    }
+    if (ref)
+       sv = newRV(ref);
+    if (sv)
+       sv_2mortal(sv);
+    else
+       sv = &sv_undef;
+    XPUSHs(sv);
+    RETURN;
+}
+
 PP(pp_and)
 {
     dSP;
@@ -148,8 +206,12 @@ PP(pp_concat)
        s = SvPV(left,len);
        sv_setpvn(TARG,s,len);
     }
-    else if (!SvOK(TARG))
+    else if (SvGMAGICAL(TARG))
+       mg_get(TARG);
+    else if (!SvOK(TARG)) {
+       s = SvPV_force(TARG, len);
        sv_setpv(TARG, "");     /* Suppress warning. */
+    }
     s = SvPV(right,len);
     sv_catpvn(TARG,s,len);
     SETTARG;
@@ -161,8 +223,12 @@ PP(pp_padsv)
 {
     dSP; dTARGET;
     XPUSHs(TARG);
-    if (op->op_private & OPpLVAL_INTRO)
-       SAVECLEARSV(curpad[op->op_targ]);
+    if (op->op_flags & OPf_MOD) {
+       if (op->op_private & OPpLVAL_INTRO)
+           SAVECLEARSV(curpad[op->op_targ]);
+        else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV))
+           provide_ref(op, curpad[op->op_targ]);
+    }
     RETURN;
 }
 
@@ -307,7 +373,7 @@ PP(pp_print)
                    goto just_say_no;
 
            if (IoFLAGS(io) & IOf_FLUSH)
-               if (fflush(fp) == EOF)
+               if (Fflush(fp) == EOF)
                    goto just_say_no;
        }
     }
@@ -360,6 +426,8 @@ PP(pp_rv2av)
                    if (op->op_flags & OPf_REF ||
                      op->op_private & HINT_STRICT_REFS)
                        DIE(no_usym, "an ARRAY");
+                   if (GIMME == G_ARRAY)
+                       RETURN;
                    RETPUSHUNDEF;
                }
                sym = SvPV(sv,na);
@@ -431,6 +499,10 @@ PP(pp_rv2hv)
                    if (op->op_flags & OPf_REF ||
                      op->op_private & HINT_STRICT_REFS)
                        DIE(no_usym, "a HASH");
+                   if (GIMME == G_ARRAY) {
+                       SP--;
+                       RETURN;
+                   }
                    RETSETUNDEF;
                }
                sym = SvPV(sv,na);
@@ -502,6 +574,7 @@ PP(pp_aassign)
     ary = Null(AV*);
     hash = Null(HV*);
     while (lelem <= lastlelem) {
+       tainted = 0;            /* Each item stands on its own, taintwise. */
        sv = *lelem++;
        switch (SvTYPE(sv)) {
        case SVt_PVAV:
@@ -518,6 +591,7 @@ PP(pp_aassign)
                (void)av_store(ary,i++,sv);
                if (magic)
                    mg_set(sv);
+               tainted = 0;
            }
            break;
        case SVt_PVHV: {
@@ -542,6 +616,7 @@ PP(pp_aassign)
                    (void)hv_store(hash,tmps,len,tmpstr,0);
                    if (magic)
                        mg_set(tmpstr);
+                   tainted = 0;
                }
            }
            break;
@@ -626,7 +701,7 @@ PP(pp_aassign)
            gid = (int)getgid();
            egid = (int)getegid();
        }
-       tainting |= (euid != uid || egid != gid);
+       tainting |= (uid && (euid != uid || egid != gid));
     }
     delaymagic = 0;
     if (GIMME == G_ARRAY) {
@@ -637,16 +712,11 @@ PP(pp_aassign)
        RETURN;
     }
     else {
+       dTARGET;
        SP = firstrelem;
-       for (relem = firstrelem; relem <= lastrelem; ++relem) {
-           if (SvOK(*relem)) {
-               dTARGET;
                
-               SETi(lastrelem - firstrelem + 1);
-               RETURN;
-           }
-       }
-       RETSETUNDEF;
+       SETi(lastrelem - firstrelem + 1);
+       RETURN;
     }
 }
 
@@ -664,6 +734,7 @@ PP(pp_match)
     I32 gimme = GIMME;
     STRLEN len;
     I32 minmatch = 0;
+    I32 oldsave = savestack_ix;
 
     if (op->op_flags & OPf_STACKED)
        TARG = POPs;
@@ -752,7 +823,7 @@ play_it_again:
            pm->op_pmshort = Nullsv;    /* opt is being useless */
        }
     }
-    if (regexec(rx, s, strend, truebase, minmatch,
+    if (pregexec(rx, s, strend, truebase, minmatch,
       SvSCREAM(TARG) ? TARG : Nullsv,
       safebase)) {
        curpm = pm;
@@ -788,6 +859,7 @@ play_it_again:
                ++rx->endp[0];
            goto play_it_again;
        }
+       LEAVE_SCOPE(oldsave);
        RETURN;
     }
     else {
@@ -809,6 +881,7 @@ play_it_again:
            else
                mg->mg_len = -1;
        }
+       LEAVE_SCOPE(oldsave);
        RETPUSHYES;
     }
 
@@ -835,6 +908,7 @@ yup:
        tmps = rx->startp[0] = tmps + (s - t);
        rx->endp[0] = tmps + SvCUR(pm->op_pmshort);
     }
+    LEAVE_SCOPE(oldsave);
     RETPUSHYES;
 
 nope:
@@ -849,6 +923,7 @@ ret_no:
                mg->mg_len = -1;
        }
     }
+    LEAVE_SCOPE(oldsave);
     if (gimme == G_ARRAY)
        RETURN;
     RETPUSHNO;
@@ -941,7 +1016,7 @@ do_readline()
                            *(end++) = '\n';  *end = '\0';
                            for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
                            if (hasdir) {
-                             if (isunix) trim_unixpath(SvPVX(tmpglob),rstr);
+                             if (isunix) trim_unixpath(rstr,SvPVX(tmpglob));
                              begin = rstr;
                            }
                            else {
@@ -955,6 +1030,10 @@ do_readline()
                        if (ok && sts != RMS$_NMF &&
                            sts != RMS$_DNF && sts != RMS$_FNF) ok = 0;
                        if (!ok) {
+                           if (!(sts & 1)) {
+                             SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
+                           }
+                           fclose(tmpfp);
                            fp = NULL;
                        }
                        else {
@@ -985,7 +1064,8 @@ do_readline()
 #endif
 #endif /* !CSH */
 #endif /* !MSDOS */
-               (void)do_open(last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),Nullfp);
+               (void)do_open(last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
+                             FALSE, 0, 0, Nullfp);
                fp = IoIFP(io);
 #endif /* !VMS */
                LEAVE;
@@ -995,7 +1075,7 @@ do_readline()
            SP--;
     }
     if (!fp) {
-       if (dowarn && !(IoFLAGS(io) & IOf_START))
+       if (dowarn && io && !(IoFLAGS(io) & IOf_START))
            warn("Read on closed filehandle <%s>", GvENAME(last_in_gv));
        if (GIMME == G_SCALAR) {
            (void)SvOK_off(TARG);
@@ -1046,12 +1126,13 @@ do_readline()
        if (type == OP_GLOB) {
            char *tmps;
 
-           if (SvCUR(sv) > 0)
-               SvCUR(sv)--;
-           if (*SvEND(sv) == rschar)
-               *SvEND(sv) = '\0';
-           else
-               SvCUR(sv)++;
+           if (SvCUR(sv) > 0 && SvCUR(rs) > 0) {
+               tmps = SvEND(sv) - 1;
+               if (*tmps == *SvPVX(rs)) {
+                   *tmps = '\0';
+                   SvCUR(sv)--;
+               }
+           }
            for (tmps = SvPVX(sv); *tmps; tmps++)
                if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
                    strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
@@ -1125,18 +1206,8 @@ PP(pp_helem)
            DIE(no_helem, key);
        if (op->op_private & OPpLVAL_INTRO)
            save_svref(svp);
-       else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) {
-           SV* sv = *svp;
-           if (SvGMAGICAL(sv))
-               mg_get(sv);
-           if (!SvOK(sv)) {
-               (void)SvUPGRADE(sv, SVt_RV);
-               SvRV(sv) = (op->op_private & OPpDEREF_HV ?
-                           (SV*)newHV() : (SV*)newAV());
-               SvROK_on(sv);
-               SvSETMAGIC(sv);
-           }
-       }
+       else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV))
+           provide_ref(op, *svp);
     }
     PUSHs(svp ? *svp : &sv_undef);
     RETURN;
@@ -1200,16 +1271,20 @@ PP(pp_iter)
     dSP;
     register CONTEXT *cx;
     SV *sv;
+    AV* av;
 
     EXTEND(sp, 1);
     cx = &cxstack[cxstack_ix];
     if (cx->cx_type != CXt_LOOP)
        DIE("panic: pp_iter");
+    av = cx->blk_loop.iterary;
+    if (av == stack && cx->blk_loop.iterix >= cx->blk_oldsp)
+       RETPUSHNO;
 
-    if (cx->blk_loop.iterix >= cx->blk_oldsp)
+    if (cx->blk_loop.iterix >= AvFILL(av))
        RETPUSHNO;
 
-    if (sv = AvARRAY(cx->blk_loop.iterary)[++cx->blk_loop.iterix]) {
+    if (sv = AvARRAY(av)[++cx->blk_loop.iterix]) {
        SvTEMP_off(sv);
        *cx->blk_loop.itervar = sv;
     }
@@ -1240,6 +1315,7 @@ PP(pp_subst)
     register REGEXP *rx = pm->op_pmregexp;
     STRLEN len;
     int force_on_match = 0;
+    I32 oldsave = savestack_ix;
 
     if (pm->op_pmflags & PMf_CONST)    /* known replacement string? */
        dstr = POPs;
@@ -1250,7 +1326,7 @@ PP(pp_subst)
        EXTEND(SP,1);
     }
     s = SvPV(TARG, len);
-    if (!SvPOKp(TARG) || SvREADONLY(TARG))
+    if (!SvPOKp(TARG) || SvREADONLY(TARG) || (SvTYPE(TARG) == SVt_PVGV))
        force_on_match = 1;
 
   force_it:
@@ -1311,7 +1387,7 @@ PP(pp_subst)
        c = SvPV(dstr, clen);
        if (clen <= rx->minlen) {
                                        /* can do inplace substitution */
-           if (regexec(rx, s, strend, orig, 0,
+           if (pregexec(rx, s, strend, orig, 0,
              SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
                if (force_on_match) {
                    force_on_match = 0;
@@ -1342,6 +1418,7 @@ PP(pp_subst)
                        (void)SvPOK_only(TARG);
                        SvSETMAGIC(TARG);
                        PUSHs(&sv_yes);
+                       LEAVE_SCOPE(oldsave);
                        RETURN;
                    }
                    /*SUPPRESS 560*/
@@ -1357,6 +1434,7 @@ PP(pp_subst)
                        (void)SvPOK_only(TARG);
                        SvSETMAGIC(TARG);
                        PUSHs(&sv_yes);
+                       LEAVE_SCOPE(oldsave);
                        RETURN;
                    }
                    else if (clen) {
@@ -1366,6 +1444,7 @@ PP(pp_subst)
                        (void)SvPOK_only(TARG);
                        SvSETMAGIC(TARG);
                        PUSHs(&sv_yes);
+                       LEAVE_SCOPE(oldsave);
                        RETURN;
                    }
                    else {
@@ -1373,6 +1452,7 @@ PP(pp_subst)
                        (void)SvPOK_only(TARG);
                        SvSETMAGIC(TARG);
                        PUSHs(&sv_yes);
+                       LEAVE_SCOPE(oldsave);
                        RETURN;
                    }
                    /* NOTREACHED */
@@ -1392,7 +1472,7 @@ PP(pp_subst)
                        d += clen;
                    }
                    s = rx->endp[0];
-               } while (regexec(rx, s, strend, orig, s == m,
+               } while (pregexec(rx, s, strend, orig, s == m,
                    Nullsv, TRUE));     /* (don't match same null twice) */
                if (s != d) {
                    i = strend - s;
@@ -1402,15 +1482,17 @@ PP(pp_subst)
                (void)SvPOK_only(TARG);
                SvSETMAGIC(TARG);
                PUSHs(sv_2mortal(newSViv((I32)iters)));
+               LEAVE_SCOPE(oldsave);
                RETURN;
            }
            PUSHs(&sv_no);
+           LEAVE_SCOPE(oldsave);
            RETURN;
        }
     }
     else
        c = Nullch;
-    if (regexec(rx, s, strend, orig, 0,
+    if (pregexec(rx, s, strend, orig, 0,
       SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
     long_way:
        if (force_on_match) {
@@ -1443,10 +1525,11 @@ PP(pp_subst)
                sv_catpvn(dstr, c, clen);
            if (once)
                break;
-       } while (regexec(rx, s, strend, orig, s == m, Nullsv,
+       } while (pregexec(rx, s, strend, orig, s == m, Nullsv,
            safebase));
        sv_catpvn(dstr, s, strend - s);
 
+       (void)SvOOK_off(TARG);
        Safefree(SvPVX(TARG));
        SvPVX(TARG) = SvPVX(dstr);
        SvCUR_set(TARG, SvCUR(dstr));
@@ -1457,14 +1540,17 @@ PP(pp_subst)
        (void)SvPOK_only(TARG);
        SvSETMAGIC(TARG);
        PUSHs(sv_2mortal(newSViv((I32)iters)));
+       LEAVE_SCOPE(oldsave);
        RETURN;
     }
     PUSHs(&sv_no);
+    LEAVE_SCOPE(oldsave);
     RETURN;
 
 nope:
     ++BmUSEFUL(pm->op_pmshort);
     PUSHs(&sv_no);
+    LEAVE_SCOPE(oldsave);
     RETURN;
 }
 
@@ -1604,13 +1690,24 @@ PP(pp_entersub)
 
     if (!CvROOT(cv) && !CvXSUB(cv)) {
        if (gv = CvGV(cv)) {
-           SV *tmpstr = sv_newmortal();
+           SV *tmpstr;
            GV *ngv;
+           if (SvFAKE(cv) && GvCV(gv) != cv) { /* autoloaded stub? */
+               cv = GvCV(gv);
+               if (SvTYPE(sv) == SVt_PVGV) {
+                   SvREFCNT_dec(GvCV((GV*)sv));
+                   GvCV((GV*)sv) = (CV*)SvREFCNT_inc((SV*)cv);
+               }
+               goto retry;
+           }
+           tmpstr = sv_newmortal();
            gv_efullname(tmpstr, gv);
            ngv = gv_fetchmethod(GvESTASH(gv), "AUTOLOAD");
            if (ngv && ngv != gv && (cv = GvCV(ngv))) { /* One more chance... */
                gv = ngv;
                sv_setsv(GvSV(CvGV(cv)), tmpstr);       /* Set CV's $AUTOLOAD */
+               if (tainting)
+                   sv_unmagic(GvSV(CvGV(cv)), 't');
                goto retry;
            }
            else
@@ -1619,11 +1716,14 @@ PP(pp_entersub)
        DIE("Undefined subroutine called");
     }
 
-    if ((op->op_private & OPpDEREF_DB) && !CvXSUB(cv)) {
+    gimme = GIMME;
+    if ((op->op_private & OPpENTERSUB_DB) && !CvXSUB(cv)) {
        sv = GvSV(DBsub);
        save_item(sv);
-       if (SvFLAGS(cv) & SVpcv_ANON)   /* Is GV potentially non-unique? */
+       if (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) {
+           /* GV is potentially non-unique */
            sv_setsv(sv, newRV((SV*)cv));
+       }
        else {
            gv = CvGV(cv);
            gv_efullname(sv,gv);
@@ -1633,8 +1733,6 @@ PP(pp_entersub)
            DIE("No DBsub routine");
     }
 
-    gimme = GIMME;
-
     if (CvXSUB(cv)) {
        if (CvOLDSTYLE(cv)) {
            I32 (*fp3)_((int,int,int));
@@ -1780,23 +1878,31 @@ PP(pp_aelem)
            DIE(no_aelem, elem);
        if (op->op_private & OPpLVAL_INTRO)
            save_svref(svp);
-       else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV)) {
-           SV* sv = *svp;
-           if (SvGMAGICAL(sv))
-               mg_get(sv);
-           if (!SvOK(sv)) {
-               (void)SvUPGRADE(sv, SVt_RV);
-               SvRV(sv) = (op->op_private & OPpDEREF_HV ?
-                           (SV*)newHV() : (SV*)newAV());
-               SvROK_on(sv);
-               SvSETMAGIC(sv);
-           }
-       }
+       else if (op->op_private & (OPpDEREF_HV|OPpDEREF_AV))
+           provide_ref(op, *svp);
     }
     PUSHs(svp ? *svp : &sv_undef);
     RETURN;
 }
 
+void
+provide_ref(op, sv)
+OP* op;
+SV* sv;
+{
+    if (SvGMAGICAL(sv))
+       mg_get(sv);
+    if (!SvOK(sv)) {
+       if (SvREADONLY(sv))
+           croak(no_modify);
+       (void)SvUPGRADE(sv, SVt_RV);
+       SvRV(sv) = (op->op_private & OPpDEREF_HV ?
+                   (SV*)newHV() : (SV*)newAV());
+       SvROK_on(sv);
+       SvSETMAGIC(sv);
+    }
+}
+
 PP(pp_method)
 {
     dSP;
@@ -1840,7 +1946,7 @@ DIE("Can't call method \"%s\" without a package or object reference", name);
            SETs(gv);
            RETURN;
        }
-       *(stack_base + TOPMARK + 1) = iogv;
+       *(stack_base + TOPMARK + 1) = sv_2mortal(newRV(iogv));
     }
 
     if (!ob || !SvOBJECT(ob)) {