/* 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.
"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

8 files changed, 56 insertions, 103 deletions

diff --git a/embed.fnc b/embed.fnc
index 088957ae7b..49eb9c273a 100644
--- 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 36f8cbfdcc..ba4899bdca 100644
--- a/embed.h
+++ b/embed.h
@@ -275,6 +275,7 @@
 #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
@@ -2577,6 +2578,7 @@
 #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)
diff --git a/global.sym b/global.sym
index f00e96d9de..53e15a8a5f 100644
--- a/global.sym
+++ b/global.sym
@@ -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 ea0b34d084..fa01807274 100644
--- 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 16aa058fa5..091a5685cf 100644
--- 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.
diff --git a/pod/perltodo.pod b/pod/perltodo.pod
index ad1d6ce989..3f1593902f 100644
--- a/pod/perltodo.pod
+++ b/pod/perltodo.pod
@@ -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
diff --git a/pp_hot.c b/pp_hot.c
index ce294f0666..efd3bc42ba 100644
--- 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 603d526ae8..8d0ae939fb 100644
--- 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	\