pp_ctl.c - handle objects in @inc a bit more gracefully

If an object doesn't have an INC hook then don't call it. Either simply
stringify the ref (think overloads), OR, if it is a blessed coderef,
then just execute it like it was an unblessed coderef.

Also handle when an object is passed as the first argument of the
array form of call. Previously this would throw an exception as the
first argument on the stack when we call_method() would not be
blessed. When this is the scenario we pass in the array as the third
argument to the method.

Author: demerphq

pod/perldelta.pod

@@ -210,6 +210,11 @@ and New Warnings
 
 =item *
 
+L<Object with arguments in @INC does not support a hook method
+ |perldiag/"Object with arguments in @INC does not support a hook method">
+
+=item *
+
 XXX L<message|perldiag/"message">
 
 =back

pod/perldiag.pod

@@ -4461,6 +4461,14 @@ and you mentioned a variable that starts with 0 that has more than one
 digit. You probably want to remove the leading 0, or if the intent was
 to express a variable name in octal you should convert to decimal.
 
+=item Object with arguments in @INC does not support a hook method
+
+(F) You pushed an array reference hook into C<@INC> which has an object
+as the first argument, but the object doesn't support any known hooks.
+Since you used the array form of creating a hook, you should have supplied
+an object that supports either the C<INC> or C<INCDIR> methods. You
+could also use a coderef instead of an object.
+
 =item Octal number > 037777777777 non-portable
 
 (W portable) The octal number you specified is larger than 2**32-1

pp_ctl.c

@@ -4307,25 +4307,55 @@ S_require_file(pTHX_ SV *sv)
                         SvSetSV_nosteal(nsv,sv);
                     }
 
+                    const char *method = NULL;
                     SV * inc_idx_sv = save_scalar(PL_incgv);
                     sv_setiv(inc_idx_sv,inc_idx);
+                    if (sv_isobject(loader)) {
+                        /* if it is an object and it has an INC method, then
+                         * call the method.
+                         */
+                        HV *pkg = SvSTASH(SvRV(loader));
+                        GV * gv = gv_fetchmethod_pvn_flags(pkg, "INC", 3, 0);
+                        if (gv && isGV(gv)) {
+                            method = "INC";
+                        }
+                        /* But if we have no method, check if this is a
+                         * coderef, if it is then we treat it as an
+                         * unblessed coderef would be treated: we
+                         * execute it. If it is some other and it is in
+                         * an array ref wrapper, then really we don't
+                         * know what to do with it, (why use the
+                         * wrapper?) and we throw an exception to help
+                         * debug. If it is not in a wrapper assume it
+                         * has an overload and treat it as a string.
+                         * Maybe in the future we can detect if it does
+                         * have overloading and throw an error if not.
+                         */
+                        if (!method) {
+                            if (SvTYPE(SvRV(loader)) != SVt_PVCV) {
+                                if (dirsv != loader)
+                                    croak("Object with arguments in @INC does not support a hook method");
+                                else
+                                    goto treat_as_string;
+                            }
+                        }
+                    }
 
                     ENTER_with_name("call_INC_hook");
                     SAVETMPS;
-                    EXTEND(SP, 2);
-
+                    EXTEND(SP, 2 + ((method && (loader != dirsv)) ? 1 : 0));
                     PUSHMARK(SP);
-                    PUSHs(dirsv);
+                    PUSHs(method ? loader : dirsv); /* always use the object for method calls */
                     PUSHs(nsv);
+                    if (method && (loader != dirsv)) /* add the args array for method calls */
+                        PUSHs(dirsv);
                     PUTBACK;
                     if (SvGMAGICAL(loader)) {
                         SV *l = sv_newmortal();
                         sv_setsv_nomg(l, loader);
                         loader = l;
                     }
-                    const char *method = NULL;
-                    if (sv_isobject(loader)) {
-                        method = "INC";
+                    if (method) {
                         count = call_method(method, G_LIST|G_EVAL);
                     } else {
                         count = call_sv(loader, G_LIST|G_EVAL);
@@ -4482,12 +4512,13 @@ S_require_file(pTHX_ SV *sv)
                         filter_sub = NULL;
                     }
                 }
-                else if (path_searchable) {
+                else
+                    treat_as_string:
+                    if (path_searchable) {
                     /* match against a plain @INC element (non-searchable
                      * paths are only matched against refs in @INC) */
                     const char *dir;
                     STRLEN dirlen;
-
                     if (SvOK(dirsv)) {
                         dir = SvPV_nomg_const(dirsv, dirlen);
                     } else {

t/op/require_errors.t

@@ -348,7 +348,6 @@ like $@, qr/^Can't locate \Q$nonsearch\E at/,
         { }, 'INCDIR works as expected');
 }
 {
-    local $::TODO = "Pending object handling improvements";
     # as of 5.37.7
     fresh_perl_like(
         '@INC = ("a",bless({},"CB"),"e");'
@@ -357,7 +356,6 @@ like $@, qr/^Can't locate \Q$nonsearch\E at/,
         { }, 'Objects with no INC or INCDIR method are stringified');
 }
 {
-    local $::TODO = "Pending object handling improvements";
     # as of 5.37.7
     fresh_perl_like(
         '{package CB; use overload qw("")=>sub { "blorg"};} '
@@ -367,7 +365,6 @@ like $@, qr/^Can't locate \Q$nonsearch\E at/,
         { }, 'Objects with overload and no INC or INCDIR method are stringified');
 }
 {
-    local $::TODO = "Pending object handling improvments";
     # as of 5.37.7
     fresh_perl_like(
         '@INC = ("a",bless(sub { warn "blessed sub called" },"CB"),"e");'
@@ -376,7 +373,6 @@ like $@, qr/^Can't locate \Q$nonsearch\E at/,
         { }, 'Blessed subs with no hook methods are executed');
 }
 {
-    local $::TODO = "Pending better error messages (eval)";
     # as of 5.37.7
     fresh_perl_like(
         '@INC = ("a",bless(sub { die "blessed sub called" },"CB"),"e");'
@@ -394,7 +390,6 @@ like $@, qr/^Can't locate \Q$nonsearch\E at/,
         { }, 'Blessed subs with methods call method and produce expected message');
 }
 {
-    local $::TODO = "Pending object handling improvments";
     # as of 5.37.7
     fresh_perl_like(
         '@INC = ("a",[bless([],"CB"),1],"e");'