diff options
| -rw-r--r-- | embed.fnc | 2 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | global.sym | 1 | ||||
| -rw-r--r-- | gv.c | 52 | ||||
| -rw-r--r-- | gv.h | 2 | ||||
| -rw-r--r-- | pod/perltodo.pod | 19 | ||||
| -rw-r--r-- | pp_hot.c | 76 | ||||
| -rw-r--r-- | proto.h | 5 |
8 files changed, 56 insertions, 103 deletions
@@ -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 @@ -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 @@ -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); @@ -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 @@ -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; } @@ -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 \ |