pp_ctl.c - add support for an INCDIR hook

This hook returns a list of directories for Perl to search.
If it returns an empty list it acts like a no-op (except for the
error message). The return from INCDIR is always stringified,
they are not treated the same as normal @inc entries so no hooks
returning hooks.

Author: demerphq

pp_ctl.c

@@ -4266,11 +4266,32 @@ S_require_file(pTHX_ SV *sv)
         if (vms_unixname)
 #endif
         {
-            SV *nsv = sv;
+            AV *incdir_av = (AV*)sv_2mortal((SV*)newAV());
+            SV *nsv = sv; /* non const copy we can change if necessary */
             namesv = newSV_type(SVt_PV);
             AV *inc_ar = GvAVn(PL_incgv);
-            for (inc_idx = 0; inc_idx <= AvFILL(inc_ar); inc_idx++) {
-                SV *dirsv = *av_fetch(inc_ar, inc_idx, TRUE);
+            SSize_t incdir_continue_inc_idx = -1;
+
+            for (
+                inc_idx = 0;
+                (AvFILL(incdir_av)>=0 /* we have INCDIR items pending */
+                    || inc_idx <= AvFILL(inc_ar));  /* @INC entries remain */
+                inc_idx++
+            ) {
+                SV *dirsv;
+
+                /* do we have any pending INCDIR items? */
+                if (AvFILL(incdir_av)>=0) {
+                    /* yep, shift it out */
+                    dirsv = av_shift(incdir_av);
+                    if (AvFILL(incdir_av)<0) {
+                        /* incdir is now empty, continue from where
+                         * we left off after we process this entry  */
+                        inc_idx = incdir_continue_inc_idx;
+                    }
+                } else {
+                    dirsv = *av_fetch(inc_ar, inc_idx, TRUE);
+                }
 
                 if (SvGMAGICAL(dirsv)) {
                     SvGETMAGIC(dirsv);
@@ -4289,6 +4310,7 @@ S_require_file(pTHX_ SV *sv)
                     int count;
                     SV **svp;
                     SV *loader = dirsv;
+                    UV diruv = PTR2UV(SvRV(dirsv));
 
                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
                         && !SvOBJECT(SvRV(loader)))
@@ -4298,7 +4320,7 @@ S_require_file(pTHX_ SV *sv)
                     }
 
                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%" UVxf "/%s",
-                                   PTR2UV(SvRV(dirsv)), name);
+                                   diruv, name);
                     tryname = SvPVX_const(namesv);
                     tryrsfp = NULL;
 
@@ -4308,6 +4330,7 @@ S_require_file(pTHX_ SV *sv)
                     }
 
                     const char *method = NULL;
+                    bool is_incdir = FALSE;
                     SV * inc_idx_sv = save_scalar(PL_incgv);
                     sv_setiv(inc_idx_sv,inc_idx);
                     if (sv_isobject(loader)) {
@@ -4318,6 +4341,12 @@ S_require_file(pTHX_ SV *sv)
                         GV * gv = gv_fetchmethod_pvn_flags(pkg, "INC", 3, 0);
                         if (gv && isGV(gv)) {
                             method = "INC";
+                        } else {
+                            gv = gv_fetchmethod_pvn_flags(pkg, "INCDIR", 6, 0);
+                            if (gv && isGV(gv)) {
+                                method = "INCDIR";
+                                is_incdir = TRUE;
+                            }
                         }
                         /* But if we have no method, check if this is a
                          * coderef, if it is then we treat it as an
@@ -4367,6 +4396,48 @@ S_require_file(pTHX_ SV *sv)
                         SV *arg;
 
                         SP -= count - 1;
+
+                        if (is_incdir) {
+                            /* push the stringified returned items into the
+                             * incdir_av array for processing immediately
+                             * afterwards. we deliberately stringify or copy
+                             * "special" arguments, so that overload logic for
+                             * instance applies, but so that the end result is
+                             * stable. We speficially do *not* support returning
+                             * coderefs from an INCDIR call. */
+                            while (count-->0) {
+                                arg = SP[i++];
+                                SvGETMAGIC(arg);
+                                if (!SvOK(arg))
+                                    continue;
+                                if (SvROK(arg)) {
+                                    STRLEN l;
+                                    char *pv = SvPV(arg,l);
+                                    arg = newSVpvn(pv,l);
+                                }
+                                else if (SvGMAGICAL(arg)) {
+                                    arg = newSVsv_nomg(arg);
+                                }
+                                else {
+                                    SvREFCNT_inc(arg);
+                                }
+                                av_push(incdir_av, arg);
+                            }
+                            /* We copy $INC into incdir_continue_inc_idx
+                             * so that when we finish processing the items
+                             * we just inserted into incdir_av we can continue
+                             * as though we had just finished executing the INCDIR
+                             * hook. We honour $INC here just like we would for
+                             * an INC hook, the hook might have rewritten @INC
+                             * at the same time as returning something to us.
+                             */
+                            inc_idx_sv = GvSVn(PL_incgv);
+                            incdir_continue_inc_idx = SvOK(inc_idx_sv)
+                                                      ? SvIV(inc_idx_sv) : -1;
+
+                            goto done_hook;
+                        }
+
                         arg = SP[i++];
 
                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
@@ -4415,6 +4486,7 @@ S_require_file(pTHX_ SV *sv)
                             tryrsfp = PerlIO_open(BIT_BUCKET,
                                                   PERL_SCRIPT_MODE);
                         }
+                        done_hook:
                         SP--;
                     } else {
                         SV *errsv= ERRSV;

t/op/inccode.t

@@ -399,7 +399,6 @@ if ($can_fork) {
 }
 SKIP:{
     skip "need fork",1 unless $can_fork;
-    local $::TODO = "Pending";
     fresh_perl_like('@INC=("A",bless({},"Hook"),"D"); '
                  .'sub Hook::INCDIR { return "B","C"} '
                  .'eval "require Frobnitz" or print $@;',

t/op/require_errors.t

@@ -338,7 +338,6 @@ like $@, qr/^Can't locate \Q$nonsearch\E at/,
         { }, 'INC hooks that overwrite @INC and undef $INC continue at start');
 }
 {
-    local $::TODO = "Pending new feature: INCDIR";
     # as of 5.37.7
     fresh_perl_like(
         'sub CB::INCDIR { return "b", "c","d" }; '
@@ -398,7 +397,6 @@ like $@, qr/^Can't locate \Q$nonsearch\E at/,
         { }, 'Blessed objects with no hook methods in array form produce expected exception');
 }
 {
-    local $::TODO = "Pending new feature: INCDIR";
     # as of 5.37.7
     fresh_perl_like(
         'sub CB::INCDIR { "i" } sub CB2::INCDIR { }'
@@ -408,7 +406,6 @@ like $@, qr/^Can't locate \Q$nonsearch\E at/,
         { }, 'Blessed subs with INCDIR methods call INCDIR');
 }
 {
-    local $::TODO = "Pending new feature: INCDIR";
     # as of 5.37.7
     fresh_perl_like(
         'sub CB::INCDIR { return @{$_[2]} }'