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
#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)
Perl_gv_fetchmeth_autoload
Perl_gv_fetchmethod
Perl_gv_fetchmethod_autoload
+Perl_gv_fetchmethod_flags
Perl_gv_fetchpv
Perl_gv_fullname
Perl_gv_fullname3
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;
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);
#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.
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
}
}
- 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;
}
#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 \
projects / p5sagit/p5-mst-13.2.git / commitdiff