Use PERL=../miniperl

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

diff --git a/gv.c b/gv.c
index 276267e..b3faf16 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -147,9 +147,7 @@ I32 level;
        if (GvCVGEN(topgv) >= sub_generation)
            return topgv;       /* valid cached inheritance */
        if (!GvCVGEN(topgv)) {  /* not an inheritance cache */
-           if (CvROOT(cv) || CvXSUB(cv))
-               return topgv;   /* real definition */
-           /* a simple undef -- save the slot for possible re-use */
+           return topgv;
        }
        else {
            /* stale cached entry, just junk it */
@@ -225,10 +223,55 @@ char* name;
        if (*nsplit == ':')
            --nsplit;
        *nsplit = '\0';
-       stash = gv_stashpv(origname,TRUE);
-       *nsplit = ch;
+       if (strEQ(origname,"SUPER")) {
+           /* Degenerate case ->SUPER::method should really lookup in original stash */
+           SV *tmpstr = sv_2mortal(newSVpv(HvNAME(curcop->cop_stash),0));
+           sv_catpvn(tmpstr, "::SUPER", 7);
+           stash = gv_stashpv(SvPV(tmpstr,na),TRUE);
+           *nsplit = ch;
+           DEBUG_o( deb("Treating %s as %s::%s\n",origname,HvNAME(stash),name) );
+       } else {
+           stash = gv_stashpv(origname,TRUE);
+           *nsplit = ch;
+       }
     }
     gv = gv_fetchmeth(stash, name, nend - name, 0);
+
+    if (!gv) {
+       /* Failed obvious case - look for SUPER as last element of stash's name */
+       char *packname = HvNAME(stash);
+       STRLEN len     = strlen(packname);
+       if (len >= 7 && strEQ(packname+len-7,"::SUPER")) {
+           /* Now look for @.*::SUPER::ISA */
+           GV** gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
+           if (!gvp || (gv = *gvp) == (GV*)&sv_undef || !GvAV(gv)) {
+               /* No @ISA in package ending in ::SUPER - drop suffix
+                  and see if there is an @ISA there
+                */
+               HV *basestash;
+               char ch = packname[len-7];
+               AV *av;
+               packname[len-7] = '\0';
+               basestash = gv_stashpv(packname, TRUE);
+               packname[len-7] = ch;
+               gvp = (GV**)hv_fetch(basestash,"ISA",3,FALSE);
+               if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
+                    /* Okay found @ISA after dropping the SUPER, alias it */
+                    SV *tmpstr = sv_2mortal(newSVpv(HvNAME(stash),0));
+                    sv_catpvn(tmpstr, "::ISA", 5);
+                    gv  = gv_fetchpv(SvPV(tmpstr,na),TRUE,SVt_PVGV);
+                     if (gv) {
+                       GvAV(gv) = (AV*)SvREFCNT_inc(av);
+                       /* ... and re-try lookup */
+                       gv = gv_fetchmeth(stash, name, nend - name, 0);
+                    } else {
+                       croak("Cannot create %s::ISA",HvNAME(stash));
+                    }
+               }
+           }
+       }     
+    }
+
     if (!gv) {
        CV* cv;
 
@@ -255,7 +298,11 @@ I32 create;
     char tmpbuf[1234];
     HV *stash;
     GV *tmpgv;
-    sprintf(tmpbuf,"%.*s::",1200,name);
+    /* Use strncpy to avoid bug in VMS sprintf */
+    /* sprintf(tmpbuf,"%.*s::",1200,name); */
+    strncpy(tmpbuf, name, 1200);
+    tmpbuf[1200] = '\0';  /* just in case . . . */
+    strcat(tmpbuf, "::");
     tmpgv = gv_fetchpv(tmpbuf,create, SVt_PVHV);
     if (!tmpgv)
        return 0;
@@ -374,9 +421,30 @@ I32 sv_type;
                if (add && (hints & HINT_STRICT_VARS) &&
                    sv_type != SVt_PVCV &&
                    sv_type != SVt_PVGV &&
+                   sv_type != SVt_PVFM &&
                    sv_type != SVt_PVIO)
                {
+                   gvp = (GV**)hv_fetch(stash,name,len,0);
+                   if (!gvp ||
+                           *gvp == (GV*)&sv_undef ||
+                           SvTYPE(*gvp) != SVt_PVGV ||
+                           !(GvFLAGS(*gvp) & GVf_IMPORTED))
+                       stash = 0;
+                   else if (sv_type == SVt_PVAV && !GvAV(*gvp) ||
+                            sv_type == SVt_PVHV && !GvHV(*gvp) ||
+                            sv_type == SVt_PV &&
+                                (!GvSV(*gvp) ||
+                                   (!SvTYPE(GvSV(*gvp)) &&
+                                    SvREFCNT(GvSV(*gvp)) == 1) ))
+                   {
+                       warn("Variable \"%c%s\" is not exported",
+                           sv_type == SVt_PVAV ? '@' :
+                           sv_type == SVt_PVHV ? '%' : '$',
+                           name);
+                       if (GvCV(*gvp))
+                           warn("(Did you mean &%s instead?)\n", name);
                        stash = 0;
+                   }
                }
            }
            else
@@ -835,7 +903,7 @@ HV* stash;
           }
           if (cv) filled=1;
          else {
-           die("Method for operation %s not found in package %.200s during blessing\n",
+           die("Method for operation %s not found in package %.256s during blessing\n",
                cp,HvNAME(stash));
            return FALSE;
          }
@@ -966,7 +1034,7 @@ int flags;
                                             * argument found */
       lr=1;
     } else if (((ocvp && oamtp->fallback > AMGfallNEVER 
-                && (cvp=ocvp) && (lr=-1)) 
+                && (cvp=ocvp) && (lr = -1)) 
                || (cvp && amtp->fallback > AMGfallNEVER && (lr=1)))
               && !(flags & AMGf_unary)) {
                                /* We look for substitution for
@@ -1004,10 +1072,9 @@ int flags;
       } else if (cvp && (cv=cvp[nomethod_amg])) {
        notfound = 1; lr = 1;
       } else {
-       char tmpstr[512];
         if (off==-1) off=method;
-       sprintf(tmpstr,"Operation `%s': no method found,\n\tleft argument %s%.200s,\n\tright argument %s%.200s",
-                     ((char**)AMG_names)[off],
+       sprintf(buf, "Operation `%s': no method found,\n\tleft argument %s%.256s,\n\tright argument %s%.256s",
+                     ((char**)AMG_names)[method],
                      SvAMAGIC(left)? 
                        "in overloaded package ":
                        "has no overloaded magic",
@@ -1021,16 +1088,16 @@ int flags;
                        HvNAME(SvSTASH(SvRV(right))):
                        "");
        if (amtp && amtp->fallback >= AMGfallYES) {
-         DEBUG_o( deb(tmpstr) );
+         DEBUG_o( deb(buf) );
        } else {
-         die(tmpstr);
+         die(buf);
        }
        return NULL;
       }
     }
   }
   if (!notfound) {
-    DEBUG_o( deb("Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.200s%s\n",
+    DEBUG_o( deb("Overloaded operator `%s'%s%s%s:\n\tmethod%s found%s in package %.256s%s\n",
                 ((char**)AMG_names)[off],
                 method+assignshift==off? "" :
                             " (initially `",