From: Slaven Rezic <slaven@rezic.de>
Date: Sun, 3 Nov 2002 10:59:43 +0000 (+0100)
Subject: Re: [perl #18203] Recursive call in PerlIO_find_layer
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d7a09b413c09654b842604d673ae0943eb928a18;p=p5sagit%2Fp5-mst-13.2.git

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
--- 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
--- 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
--- 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
--- 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
--- 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;