This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
/* This code tries to figure out just what went wrong with
authorNicholas Clark <nick@ccl4.org>
Thu, 17 Apr 2008 07:58:29 +0000 (07:58 +0000)
committerNicholas Clark <nick@ccl4.org>
Thu, 17 Apr 2008 07:58:29 +0000 (07:58 +0000)
   gv_fetchmethod.  It therefore needs to duplicate a lot of
          the internals of that function.
"Duplicate". <snigger>. You said a naughty word. Now sanitised.

[All tests pass, but I'm not 100% confident that this code is
 equivalent in all reachable corner cases, and it may be possible
 to simplify the error reporting logic now in gv_fetchmethod_flags]

p4raw-id: //depot/perl@33702

embed.fnc
embed.h
global.sym
gv.c
gv.h
pod/perltodo.pod
pp_hot.c
proto.h

index 088957a..49eb9c2 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -299,6 +299,8 @@ Apd |GV*    |gv_fetchmeth   |NULLOK HV* stash|NN const char* name|STRLEN len|I32 leve
 Apd    |GV*    |gv_fetchmeth_autoload  |NULLOK HV* stash|NN const char* name|STRLEN len|I32 level
 Apdmb  |GV*    |gv_fetchmethod |NULLOK HV* stash|NN const char* name
 Apd    |GV*    |gv_fetchmethod_autoload|NULLOK HV* stash|NN const char* name|I32 autoload
+ApdM   |GV*    |gv_fetchmethod_flags|NULLOK HV* stash|NN const char* name \
+                               |U32 flags
 Ap     |GV*    |gv_fetchpv     |NN const char *nambeg|I32 add|const svtype sv_type
 Ap     |void   |gv_fullname    |NN SV* sv|NN const GV* gv
 Apmb   |void   |gv_fullname3   |NN SV* sv|NN const GV* gv|NULLOK const char* prefix
diff --git a/embed.h b/embed.h
index 36f8cbf..ba4899b 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define gv_fetchmeth           Perl_gv_fetchmeth
 #define gv_fetchmeth_autoload  Perl_gv_fetchmeth_autoload
 #define gv_fetchmethod_autoload        Perl_gv_fetchmethod_autoload
+#define gv_fetchmethod_flags   Perl_gv_fetchmethod_flags
 #define gv_fetchpv             Perl_gv_fetchpv
 #define gv_fullname            Perl_gv_fullname
 #define gv_fullname4           Perl_gv_fullname4
 #define gv_fetchmeth(a,b,c,d)  Perl_gv_fetchmeth(aTHX_ a,b,c,d)
 #define gv_fetchmeth_autoload(a,b,c,d) Perl_gv_fetchmeth_autoload(aTHX_ a,b,c,d)
 #define gv_fetchmethod_autoload(a,b,c) Perl_gv_fetchmethod_autoload(aTHX_ a,b,c)
+#define gv_fetchmethod_flags(a,b,c)    Perl_gv_fetchmethod_flags(aTHX_ a,b,c)
 #define gv_fetchpv(a,b,c)      Perl_gv_fetchpv(aTHX_ a,b,c)
 #define gv_fullname(a,b)       Perl_gv_fullname(aTHX_ a,b)
 #define gv_fullname4(a,b,c,d)  Perl_gv_fullname4(aTHX_ a,b,c,d)
index f00e96d..53e15a8 100644 (file)
@@ -140,6 +140,7 @@ Perl_gv_fetchmeth
 Perl_gv_fetchmeth_autoload
 Perl_gv_fetchmethod
 Perl_gv_fetchmethod_autoload
+Perl_gv_fetchmethod_flags
 Perl_gv_fetchpv
 Perl_gv_fullname
 Perl_gv_fullname3
diff --git a/gv.c b/gv.c
index ea0b34d..fa01807 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -599,26 +599,26 @@ 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. ...
-
-   I'd guess that with one more flag bit that could all be moved inside
-   here.
-*/
-
 GV *
 Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload)
 {
+    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_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;
 
@@ -665,6 +665,36 @@ 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, HvNAMELEN_get(stash), HvNAME_get(stash));
+           }
+           else {
+               STRLEN packlen;
+               const char *packname;
+
+               assert(error_report);
+
+               if (nsplit) {
+                   packlen = nsplit - origname;
+                   packname = origname;
+               } else if (SvTYPE(error_report) == SVt_PVHV) {
+                   packlen = HvNAMELEN_get(error_report);
+                   packname = HvNAME_get(error_report);
+               } 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);
diff --git a/gv.h b/gv.h
index 16aa058..091a568 100644 (file)
--- a/gv.h
+++ b/gv.h
@@ -206,6 +206,8 @@ Return the SV from the GV.
 #define GV_NOEXPAND    0x40    /* Don't expand SvOK() entries to PVGV */
 #define GV_NOTQUAL     0x80    /* A plain symbol name, not qualified with a
                                   package (so skip checks for :: and ')  */
+#define GV_AUTOLOAD    0x100   /* gv_fetchmethod_flags() should AUTOLOAD  */
+#define GV_CROAK       0x200   /* gv_fetchmethod_flags() should croak  */
 
 /*      SVf_UTF8 (more accurately the return value from SvUTF8) is also valid
        as a flag to gv_fetch_pvn_flags, so ensure it lies outside this range.
index ad1d6ce..3f15939 100644 (file)
@@ -664,25 +664,6 @@ only the interpretation of non-ASCII characters, and not for the script file
 handle. To make it work needs some investigation of the ordering of function
 calls during startup, and (by implication) a bit of tweaking of that order.
 
-=head2 Duplicate logic in S_method_common() and Perl_gv_fetchmethod_autoload()
-
-A comment in C<S_method_common> notes
-
-       /* 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.  We can't move it inside
-          Perl_gv_fetchmethod_autoload(), however, since that would
-          cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
-          don't want that.
-       */
-
-If C<Perl_gv_fetchmethod_autoload> gets rewritten to take (more) flag bits,
-then it ought to be possible to move the logic from C<S_method_common> to
-the "right" place. When making this change it would probably be good to also
-pass in at least the method name length, if not also pre-computed hash values
-when known. (I'm contemplating a plan to pre-compute hash values for common
-fixed strings such as C<ISA> and pass them in to functions.)
-
 =head2 Organize error messages
 
 Perl's diagnostics (error messages, see L<perldiag>) could use
index ce294f0..efd3bc4 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -3084,81 +3084,11 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
        }
     }
 
-    gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
-
-    if (!gv) {
-       /* 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.  We can't move it inside
-          Perl_gv_fetchmethod_autoload(), however, since that would
-          cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
-          don't want that.
-       */
-       const char* leaf = name;
-       const char* sep = NULL;
-       const char* p;
-
-       for (p = name; *p; p++) {
-           if (*p == '\'')
-               sep = p, leaf = p + 1;
-           else if (*p == ':' && *(p + 1) == ':')
-               sep = p, leaf = p + 2;
-       }
-       if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
-           /* the method name is unqualified or starts with SUPER:: */
-#ifndef USE_ITHREADS
-           if (sep)
-               stash = CopSTASH(PL_curcop);
-#else
-           bool need_strlen = 1;
-           if (sep) {
-               packname = CopSTASHPV(PL_curcop);
-           }
-           else
-#endif
-           if (stash) {
-               HEK * const packhek = HvNAME_HEK(stash);
-               if (packhek) {
-                   packname = HEK_KEY(packhek);
-                   packlen = HEK_LEN(packhek);
-#ifdef USE_ITHREADS
-                   need_strlen = 0;
-#endif
-               } else {
-                   goto croak;
-               }
-           }
+    gv = gv_fetchmethod_flags(stash ? stash : (HV*)packsv, name,
+                             GV_AUTOLOAD | GV_CROAK);
 
-           if (!packname) {
-           croak:
-               Perl_croak(aTHX_
-                          "Can't use anonymous symbol table for method lookup");
-           }
-#ifdef USE_ITHREADS
-           if (need_strlen)
-               packlen = strlen(packname);
-#endif
+    assert(gv);
 
-       }
-       else {
-           /* the method name is qualified */
-           packname = name;
-           packlen = sep - name;
-       }
-       
-       /* we're relying on gv_fetchmethod not autovivifying the stash */
-       if (gv_stashpvn(packname, packlen, 0)) {
-           Perl_croak(aTHX_
-                      "Can't locate object method \"%s\" via package \"%.*s\"",
-                      leaf, (int)packlen, packname);
-       }
-       else {
-           Perl_croak(aTHX_
-                      "Can't locate object method \"%s\" via package \"%.*s\""
-                      " (perhaps you forgot to load \"%.*s\"?)",
-                      leaf, (int)packlen, packname, (int)packlen, packname);
-       }
-    }
     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
 }
 
diff --git a/proto.h b/proto.h
index 603d526..8d0ae93 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -903,6 +903,11 @@ PERL_CALLCONV GV*  Perl_gv_fetchmethod_autoload(pTHX_ HV* stash, const char* name
 #define PERL_ARGS_ASSERT_GV_FETCHMETHOD_AUTOLOAD       \
        assert(name)
 
+PERL_CALLCONV GV*      Perl_gv_fetchmethod_flags(pTHX_ HV* stash, const char* name, U32 flags)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_GV_FETCHMETHOD_FLAGS  \
+       assert(name)
+
 PERL_CALLCONV GV*      Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, const svtype sv_type)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_GV_FETCHPV    \