Fix require’s get-magic handling for @INC elements

It was only calling get-magic before checking whether the argument was
a reference if the array was tied, which is not the only thing that
can cause an @INC element to have get-magic.  It should have been
checking for get-magic on the element itself (which is a faster
check, too).

And then there were too many FETCH calls.

I do not know whether we should be calling get-magic exactly once
when the ‘Can’t locate’ error occurs.  At least this commit reduces
the number of FETCHes.

diff --git a/pp_ctl.c b/pp_ctl.c
index d47e983..fcfa3a1 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3815,17 +3815,17 @@ PP(pp_require)
            for (i = 0; i <= AvFILL(ar); i++) {
                SV * const dirsv = *av_fetch(ar, i, TRUE);
 
-               if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
-                   mg_get(dirsv);
+               SvGETMAGIC(dirsv);
                if (SvROK(dirsv)) {
                    int count;
                    SV **svp;
                    SV *loader = dirsv;
 
                    if (SvTYPE(SvRV(loader)) == SVt_PVAV
-                       && !sv_isobject(loader))
+                       && !SvOBJECT(SvRV(loader)))
                    {
                        loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
+                       SvGETMAGIC(loader);
                    }
 
                    Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
@@ -3846,6 +3846,11 @@ PP(pp_require)
                    PUSHs(dirsv);
                    PUSHs(nsv);
                    PUTBACK;
+                   if (SvGMAGICAL(loader)) {
+                       SV *l = sv_newmortal();
+                       sv_setsv_nomg(l, loader);
+                       loader = l;
+                   }
                    if (sv_isobject(loader))
                        count = call_method("INC", G_ARRAY);
                    else
@@ -3946,7 +3951,7 @@ PP(pp_require)
                    STRLEN dirlen;
 
                    if (SvOK(dirsv)) {
-                       dir = SvPV_const(dirsv, dirlen);
+                       dir = SvPV_nomg_const(dirsv, dirlen);
                    } else {
                        dir = "";
                        dirlen = 0;

diff --git a/t/op/inccode.t b/t/op/inccode.t
index 0712956..1a0b919 100644 (file)
--- a/t/op/inccode.t
+++ b/t/op/inccode.t
@@ -21,7 +21,7 @@ unless (is_miniperl()) {
 
 use strict;
 
-plan(tests => 62 + !is_miniperl() * (3 + 14 * $can_fork));
+plan(tests => 68 + !is_miniperl() * (3 + 14 * $can_fork));
 
 sub get_temp_fh {
     my $f = tempfile();
@@ -280,6 +280,40 @@ sub fake_module {
         'require PADTMP passing freed var when @INC has multiple subs';\r
 }    
 
+SKIP: {
+    skip ("Not applicable when run from inccode-tie.t", 6) if tied @INC;
+    require Tie::Scalar;
+    package INCtie {
+        sub TIESCALAR { bless \my $foo }
+        sub FETCH { study; our $count++; ${$_[0]} }
+    }
+    local @INC = undef;
+    my $t = tie $INC[0], 'INCtie';
+    my $called;
+    $$t = sub { $called ++; !1 };
+    delete $INC{'foo.pm'}; # in case another test uses foo
+    eval { require foo };
+    is $INCtie::count, 2, # 2nd time for "Can't locate" -- XXX correct?
+        'FETCH is called once on undef scalar-tied @INC elem';
+    is $called, 1, 'sub in scalar-tied @INC elem is called';
+    () = "$INC[0]"; # force a fetch, so the SV is ROK
+    $INCtie::count = 0;
+    eval { require foo };
+    is $INCtie::count, 2,
+        'FETCH is called once on scalar-tied @INC elem holding ref';
+    is $called, 2, 'sub in scalar-tied @INC elem holding ref is called';
+    $$t = [];
+    $INCtie::count = 0;
+    eval { require foo };
+    is $INCtie::count, 1,
+       'FETCH called once on scalar-tied @INC elem returning array';
+    $$t = "string";
+    $INCtie::count = 0;
+    eval { require foo };
+    is $INCtie::count, 2,
+       'FETCH called once on scalar-tied @INC elem returning string';
+}
+
 
 exit if is_miniperl();