Re: [perl #18203] Recursive call in PerlIO_find_layer

Message-ID: <877kfvnfcg.fsf@vran.herceg.de>

p4raw-id: //depot/perl@18188

diff --git a/embedvar.h b/embedvar.h
index c1c77d2..612ebdb 100644 (file)
--- a/embedvar.h
+++ b/embedvar.h
@@ -271,6 +271,7 @@
 #define PL_hints               (vTHX->Ihints)
 #define PL_in_clean_all                (vTHX->Iin_clean_all)
 #define PL_in_clean_objs       (vTHX->Iin_clean_objs)
+#define PL_in_load_module      (vTHX->Iin_load_module)
 #define PL_in_my               (vTHX->Iin_my)
 #define PL_in_my_stash         (vTHX->Iin_my_stash)
 #define PL_incgv               (vTHX->Iincgv)
@@ -559,6 +560,7 @@
 #define PL_Ihints              PL_hints
 #define PL_Iin_clean_all       PL_in_clean_all
 #define PL_Iin_clean_objs      PL_in_clean_objs
+#define PL_Iin_load_module     PL_in_load_module
 #define PL_Iin_my              PL_in_my
 #define PL_Iin_my_stash                PL_in_my_stash
 #define PL_Iincgv              PL_incgv

diff --git a/intrpvar.h b/intrpvar.h
index d4f92d2..bb0b46d 100644 (file)
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -496,3 +496,5 @@ PERLVARI(Iclocktick, long, 0)       /* this many times() ticks in a second */
 /* New variables must be added to the very end for binary compatibility.
  * XSUB.h provides wrapper functions via perlapi.h that make this
  * irrelevant, but not all code may be expected to #include XSUB.h. */
+
+PERLVARI(Iin_load_module, int, 0)      /* to prevent recursions in PerlIO_find_layer */

diff --git a/lib/open.t b/lib/open.t
index 5029292..905308d 100644 (file)
--- a/lib/open.t
+++ b/lib/open.t
@@ -7,7 +7,7 @@ BEGIN {
        require Config; import Config;
 }
 
-use Test::More tests => 16;
+use Test::More tests => 17;
 
 # open::import expects 'open' as its first argument, but it clashes with open()
 sub import {
@@ -171,6 +171,15 @@ EOE
        "checking syswrite() output on :utf8 streams by reading it back in");
 }
 
+{
+    use open IN => ':non-existent';
+    eval {
+       require Anything;
+    };
+    like($@, qr/Recursive call/i,
+        "test for an endless loop in PerlIO_find_layer");
+}
+
 END {
     1 while unlink "utf8";
     1 while unlink "a";

diff --git a/perlapi.h b/perlapi.h
index 53e4ba8..0a75b51 100644 (file)
--- a/perlapi.h
+++ b/perlapi.h
@@ -274,6 +274,8 @@ END_EXTERN_C
 #define PL_in_clean_all                (*Perl_Iin_clean_all_ptr(aTHX))
 #undef  PL_in_clean_objs
 #define PL_in_clean_objs       (*Perl_Iin_clean_objs_ptr(aTHX))
+#undef  PL_in_load_module
+#define PL_in_load_module      (*Perl_Iin_load_module_ptr(aTHX))
 #undef  PL_in_my
 #define PL_in_my               (*Perl_Iin_my_ptr(aTHX))
 #undef  PL_in_my_stash

diff --git a/perlio.c b/perlio.c
index 0fca670..ea7dff0 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -660,15 +660,23 @@ PerlIO_find_layer(pTHX_ const char *name, STRLEN len, int load)
     }
     if (load && PL_subname && PL_def_layerlist
        && PL_def_layerlist->cur >= 2) {
-       SV *pkgsv = newSVpvn("PerlIO", 6);
-       SV *layer = newSVpvn(name, len);
-       ENTER;
-       /*
-        * The two SVs are magically freed by load_module
-        */
-       Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
-       LEAVE;
-       return PerlIO_find_layer(aTHX_ name, len, 0);
+       if (PL_in_load_module) {
+           Perl_croak(aTHX_ "Recursive call to Perl_load_module in PerlIO_find_layer");
+           return NULL;
+       } else {
+           SV *pkgsv = newSVpvn("PerlIO", 6);
+           SV *layer = newSVpvn(name, len);
+           ENTER;
+           SAVEINT(PL_in_load_module);
+           PL_in_load_module++;
+           /*
+            * The two SVs are magically freed by load_module
+            */
+           Perl_load_module(aTHX_ 0, pkgsv, Nullsv, layer, Nullsv);
+           PL_in_load_module--;
+           LEAVE;
+           return PerlIO_find_layer(aTHX_ name, len, 0);
+       }
     }
     PerlIO_debug("Cannot find %.*s\n", (int) len, name);
     return NULL;