more complete File::Spec support for Mac and VMS, tests (from

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

diff --git a/op.c b/op.c
index 456d786..e1d0dcd 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1,6 +1,6 @@
 /*    op.c
  *
- *    Copyright (c) 1991-1999, Larry Wall
+ *    Copyright (c) 1991-2000, 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.
@@ -3105,7 +3105,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
 
     veop = Nullop;
 
-    if(version != Nullop) {
+    if (version != Nullop) {
        SV *vesv = ((SVOP*)version)->op_sv;
 
        if (arg == Nullop && !SvNIOK(vesv)) {
@@ -3113,6 +3113,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
        }
        else {
            OP *pack;
+           SV *meth;
 
            if (version->op_type != OP_CONST || !SvNIOK(vesv))
                Perl_croak(aTHX_ "Version number must be constant number");
@@ -3121,29 +3122,38 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
            pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
 
            /* Fake up a method call to VERSION */
+           meth = newSVpvn("VERSION",7);
+           sv_upgrade(meth, SVt_PVIV);
+           SvIOK_on(meth);
+           PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
            veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
                            append_elem(OP_LIST,
-                           prepend_elem(OP_LIST, pack, list(version)),
-                           newSVOP(OP_METHOD_NAMED, 0,
-                                   newSVpvn("VERSION", 7))));
+                                       prepend_elem(OP_LIST, pack, list(version)),
+                                       newSVOP(OP_METHOD_NAMED, 0, meth)));
        }
     }
 
     /* Fake up an import/unimport */
     if (arg && arg->op_type == OP_STUB)
        imop = arg;             /* no import on explicit () */
-    else if(SvNIOK(((SVOP*)id)->op_sv)) {
+    else if (SvNIOK(((SVOP*)id)->op_sv)) {
        imop = Nullop;          /* use 5.0; */
     }
     else {
+       SV *meth;
+
        /* Make copy of id so we don't free it twice */
        pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
+
+       /* Fake up a method call to import/unimport */
+       meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
+       sv_upgrade(meth, SVt_PVIV);
+       SvIOK_on(meth);
+       PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
        imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
-                   append_elem(OP_LIST,
-                       prepend_elem(OP_LIST, pack, list(arg)),
-                       newSVOP(OP_METHOD_NAMED, 0,
-                               aver ? newSVpvn("import", 6)
-                                    : newSVpvn("unimport", 8))));
+                      append_elem(OP_LIST,
+                                  prepend_elem(OP_LIST, pack, list(arg)),
+                                  newSVOP(OP_METHOD_NAMED, 0, meth)));
     }
 
     /* Fake up a require, handle override, if any */
@@ -4247,10 +4257,10 @@ Perl_op_const_sv(pTHX_ OP *o, CV *cv)
 {
     SV *sv = Nullsv;
 
-    if(!o)
+    if (!o)
        return Nullsv;
  
-    if(o->op_type == OP_LINESEQ && cLISTOPo->op_first) 
+    if (o->op_type == OP_LINESEQ && cLISTOPo->op_first) 
        o = cLISTOPo->op_first->op_sibling;
 
     for (; o; o = o->op_next) {
@@ -4305,14 +4315,26 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
 {
     dTHR;
     STRLEN n_a;
-    char *name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
-    GV *gv = gv_fetchpv(name ? name : "__ANON__",
-                       GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
-                       SVt_PVCV);
+    char *name;
+    char *aname;
+    GV *gv;
     char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
     register CV *cv=0;
     I32 ix;
 
+    name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
+    if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
+       SV *sv = sv_newmortal();
+       Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
+                      CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
+       aname = SvPVX(sv);
+    }
+    else
+       aname = Nullch;
+    gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
+                   GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
+                   SVt_PVCV);
+
     if (o)
        SAVEFREEOP(o);
     if (proto)
@@ -4358,13 +4380,14 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
                Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
            if (!block)
                goto withattrs;
-           if(const_sv = cv_const_sv(cv))
+           if (const_sv = cv_const_sv(cv))
                const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv));
            if ((const_sv && const_changed) || ckWARN(WARN_REDEFINE) 
                                        && !(CvGV(cv) && GvSTASH(CvGV(cv))
                                        && HvNAME(GvSTASH(CvGV(cv)))
                                        && strEQ(HvNAME(GvSTASH(CvGV(cv))),
-                                                "autouse"))) {
+                                                "autouse")))
+           {
                line_t oldline = CopLINE(PL_curcop);
                CopLINE_set(PL_curcop, PL_copline);
                Perl_warner(aTHX_ WARN_REDEFINE,
@@ -4519,15 +4542,17 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        }
     }
 
-    if (name) {
+    if (name || aname) {
        char *s;
+       char *tname = (name ? name : aname);
 
        if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
            SV *sv = NEWSV(0,0);
            SV *tmpstr = sv_newmortal();
            GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
-           CV *cv;
+           CV *pcv;
            HV *hv;
+           char *t;
 
            Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
                           CopFILE(PL_curcop),
@@ -4536,19 +4561,20 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
            hv = GvHVn(db_postponed);
            if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
-                 && (cv = GvCV(db_postponed))) {
+               && (pcv = GvCV(db_postponed)))
+           {
                dSP;
                PUSHMARK(SP);
                XPUSHs(tmpstr);
                PUTBACK;
-               call_sv((SV*)cv, G_DISCARD);
+               call_sv((SV*)pcv, G_DISCARD);
            }
        }
 
-       if ((s = strrchr(name,':')))
+       if ((s = strrchr(tname,':')))
            s++;
        else
-           s = name;
+           s = tname;
 
        if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
            goto done;
@@ -5940,7 +5966,7 @@ S_simplify_sort(pTHX_ OP *o)
        return;
     if (strEQ(GvNAME(gv), "a"))
        reversed = 0;
-    else if(strEQ(GvNAME(gv), "b"))
+    else if (strEQ(GvNAME(gv), "b"))
        reversed = 1;
     else
        return;