error reporting of [$a ; $b] can be a TODO.

[perl5.git] / gv.c

diff --git a/gv.c b/gv.c
index 23a694c..da79403 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -520,7 +520,7 @@ Perl_gv_fetchmeth_autoload(pTHX_ HV *stash, const char *name, STRLEN len, I32 le
 
        if (!stash)
            return NULL;        /* UNIVERSAL::AUTOLOAD could cause trouble */
-       if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
+       if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
            return NULL;
        if (!(gv = gv_fetchmeth(stash, S_autoload, S_autolen, FALSE)))
            return NULL;
@@ -599,43 +599,51 @@ S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen)
     return stash;
 }
 
-/* FIXME. If changing this function note the comment in pp_hot's
-   S_method_common:
-
-   This code tries to figure out just what went wrong with
-   gv_fetchmethod.  It therefore needs to duplicate a lot of
-   the internals of that function. ...
+GV *
+Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
+{
+    PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
 
-   I'd guess that with one more flag bit that could all be moved inside
-   here.
-*/
+    return gv_fetchmethod_flags(stash, name, autoload ? GV_AUTOLOAD : 0);
+}
 
+/* Don't merge this yet, as it's likely to get a len parameter, and possibly
+   even a U32 hash */
 GV *
-Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
+Perl_gv_fetchmethod_flags(pTHX_ HV *stash, const char *name, U32 flags)
 {
     dVAR;
     register const char *nend;
     const char *nsplit = NULL;
     GV* gv;
     HV* ostash = stash;
+    const char * const origname = name;
+    SV *const error_report = (SV *)stash;
+    const U32 autoload = flags & GV_AUTOLOAD;
+    const U32 do_croak = flags & GV_CROAK;
 
-    PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD;
+    PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS;
 
-    if (stash && SvTYPE(stash) < SVt_PVHV)
+    if (SvTYPE(stash) < SVt_PVHV)
        stash = NULL;
+    else {
+       /* The only way stash can become NULL later on is if nsplit is set,
+          which in turn means that there is no need for a SVt_PVHV case
+          the error reporting code.  */
+    }
 
     for (nend = name; *nend; nend++) {
-       if (*nend == '\'')
+       if (*nend == '\'') {
            nsplit = nend;
-       else if (*nend == ':' && *(nend + 1) == ':')
-           nsplit = ++nend;
+           name = nend + 1;
+       }
+       else if (*nend == ':' && *(nend + 1) == ':') {
+           nsplit = nend++;
+           name = nend + 1;
+       }
     }
     if (nsplit) {
-       const char * const origname = name;
-       name = nsplit + 1;
-       if (*nsplit == ':')
-           --nsplit;
-       if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) {
+       if ((nsplit - origname) == 5 && memEQ(origname, "SUPER", 5)) {
            /* ->SUPER::method should really be looked up in original stash */
            SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER",
                                                  CopSTASHPV(PL_curcop)));
@@ -664,6 +672,31 @@ Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
            gv = (GV*)&PL_sv_yes;
        else if (autoload)
            gv = gv_autoload4(ostash, name, nend - name, TRUE);
+       if (!gv && do_croak) {
+           /* Right now this is exclusively for the benefit of S_method_common
+              in pp_hot.c  */
+           if (stash) {
+               Perl_croak(aTHX_
+                          "Can't locate object method \"%s\" via package \"%.*s\"",
+                          name, (int)HvNAMELEN_get(stash), HvNAME_get(stash));
+           }
+           else {
+               STRLEN packlen;
+               const char *packname;
+
+               if (nsplit) {
+                   packlen = nsplit - origname;
+                   packname = origname;
+               } else {
+                   packname = SvPV_const(error_report, packlen);
+               }
+
+               Perl_croak(aTHX_
+                          "Can't locate object method \"%s\" via package \"%.*s\""
+                          " (perhaps you forgot to load \"%.*s\"?)",
+                          name, (int)packlen, packname, (int)packlen, packname);
+           }
+       }
     }
     else if (autoload) {
        CV* const cv = GvCV(gv);
@@ -702,7 +735,7 @@ Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
 
     PERL_ARGS_ASSERT_GV_AUTOLOAD4;
 
-    if (len == S_autolen && strnEQ(name, S_autoload, S_autolen))
+    if (len == S_autolen && memEQ(name, S_autoload, S_autolen))
        return NULL;
     if (stash) {
        if (SvTYPE(stash) < SVt_PVHV) {