Change 33702 by [EMAIL PROTECTED] 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.
