Change 33702: /* This code tries to figure out just what went wrong with

Change 33702 by nicholas@mouse-mill on 2008/04/17 07:58:29

	/* 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]

Affected files ...

... //depot/perl/embed.fnc#612 edit
... //depot/perl/embed.h#759 edit
... //depot/perl/global.sym#355 edit
... //depot/perl/gv.c#393 edit
... //depot/perl/gv.h#77 edit
... //depot/perl/pod/perltodo.pod#220 edit
... //depot/perl/pp_hot.c#575 edit
... //depot/perl/proto.h#946 edit

Differences ...

==== //depot/perl/embed.fnc#612 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc#611~33677~	2008-04-14 08:01:49.000000000 -0700
+++ perl/embed.fnc	2008-04-17 00:58:29.000000000 -0700
@@ -299,6 +299,8 @@
 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

==== //depot/perl/embed.h#759 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#758~33677~	2008-04-14 08:01:49.000000000 -0700
+++ perl/embed.h	2008-04-17 00:58:29.000000000 -0700
@@ -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)

==== //depot/perl/global.sym#355 (text+w) ====
Index: perl/global.sym
--- perl/global.sym#354~33656~	2008-04-07 04:29:51.000000000 -0700
+++ perl/global.sym	2008-04-17 00:58:29.000000000 -0700
@@ -140,6 +140,7 @@
 Perl_gv_fetchmeth_autoload
 Perl_gv_fetchmethod
 Perl_gv_fetchmethod_autoload
+Perl_gv_fetchmethod_flags
 Perl_gv_fetchpv
 Perl_gv_fullname
 Perl_gv_fullname3

==== //depot/perl/gv.c#393 (text) ====
Index: perl/gv.c
--- perl/gv.c#392~33701~	2008-04-16 09:08:04.000000000 -0700
+++ perl/gv.c	2008-04-17 00:58:29.000000000 -0700
@@ -599,26 +599,26 @@
     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 @@
 	    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);

==== //depot/perl/gv.h#77 (text) ====
Index: perl/gv.h
--- perl/gv.h#76~33051~	2008-01-23 01:22:01.000000000 -0800
+++ perl/gv.h	2008-04-17 00:58:29.000000000 -0700
@@ -206,6 +206,8 @@
 #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.

==== //depot/perl/pod/perltodo.pod#220 (text) ====
Index: perl/pod/perltodo.pod
--- perl/pod/perltodo.pod#219~33681~	2008-04-14 10:46:26.000000000 -0700
+++ perl/pod/perltodo.pod	2008-04-17 00:58:29.000000000 -0700
@@ -664,25 +664,6 @@
 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

==== //depot/perl/pp_hot.c#575 (text) ====
Index: perl/pp_hot.c
--- perl/pp_hot.c#574~33463~	2008-03-10 10:37:30.000000000 -0700
+++ perl/pp_hot.c	2008-04-17 00:58:29.000000000 -0700
@@ -3084,81 +3084,11 @@
 	}
     }
 
-    gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
+    gv = gv_fetchmethod_flags(stash ? stash : (HV*)packsv, name,
+			      GV_AUTOLOAD | GV_CROAK);
 
-    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;
+    assert(gv);
 
-	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;
-		}
-	    }
-
-	    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
-
-	}
-	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;
 }
 

==== //depot/perl/proto.h#946 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#945~33657~	2008-04-07 07:45:33.000000000 -0700
+++ perl/proto.h	2008-04-17 00:58:29.000000000 -0700
@@ -903,6 +903,11 @@
 #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	\
End of Patch.

• Change 33702: /* This code tries to figure out just what went wrong with by Nicholas Clark