From: Steve Peters <steve@fisharerojo.org>
Date: Thu, 15 Dec 2005 17:48:42 +0000 (+0000)
Subject: Prevent require() from attempting to open directories and block
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ce8abf5f5d2e5b19646ab17c24a3ea87c70428c8;p=p5sagit%2Fp5-mst-13.2.git

Prevent require() from attempting to open directories and block
devices.  This fixes RT #24404.

p4raw-id: //depot/perl@26373
---

diff --git a/embed.fnc b/embed.fnc
index 9322526..958672d 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1178,6 +1178,7 @@ sR	|I32	|dopoptosub	|I32 startingblock
 sR	|I32	|dopoptosub_at	|NN const PERL_CONTEXT* cxstk|I32 startingblock
 s	|void	|save_lines	|NULLOK AV *array|NN SV *sv
 sR	|OP*	|doeval		|int gimme|NULLOK OP** startop|NULLOK CV* outside|U32 seq
+sR	|PerlIO *|check_type_and_open|NN const char *name|NN const char *mode
 sR	|PerlIO *|doopen_pm	|NN const char *name|NN const char *mode
 sR	|bool	|path_is_absolute|NN const char *name
 sR	|I32	|run_user_filter|int idx|NN SV *buf_sv|int maxlen
diff --git a/embed.h b/embed.h
index 9707ec2..5b1916a 100644
--- a/embed.h
+++ b/embed.h
@@ -1198,6 +1198,7 @@
 #define dopoptosub_at		S_dopoptosub_at
 #define save_lines		S_save_lines
 #define doeval			S_doeval
+#define check_type_and_open	S_check_type_and_open
 #define doopen_pm		S_doopen_pm
 #define path_is_absolute	S_path_is_absolute
 #define run_user_filter		S_run_user_filter
@@ -3208,6 +3209,7 @@
 #define dopoptosub_at(a,b)	S_dopoptosub_at(aTHX_ a,b)
 #define save_lines(a,b)		S_save_lines(aTHX_ a,b)
 #define doeval(a,b,c,d)		S_doeval(aTHX_ a,b,c,d)
+#define check_type_and_open(a,b)	S_check_type_and_open(aTHX_ a,b)
 #define doopen_pm(a,b)		S_doopen_pm(aTHX_ a,b)
 #define path_is_absolute(a)	S_path_is_absolute(aTHX_ a)
 #define run_user_filter(a,b,c)	S_run_user_filter(aTHX_ a,b,c)
diff --git a/pp_ctl.c b/pp_ctl.c
index 401f60f..7e8fed7 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2980,6 +2980,23 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
 }
 
 STATIC PerlIO *
+S_check_type_and_open(pTHX_ const char *name, const char *mode)
+{
+    Stat_t st;
+    int st_rc;
+    st_rc = PerlLIO_stat(name, &st);
+    if (st_rc < 0) {
+       return Nullfp;
+    }
+
+    if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
+       Perl_die(aTHX_ "%s %s not allowed in require",
+           S_ISDIR(st.st_mode) ? "Directory" : "Block device", name);
+    }
+    return PerlIO_open(name, mode);
+}
+
+STATIC PerlIO *
 S_doopen_pm(pTHX_ const char *name, const char *mode)
 {
 #ifndef PERL_DISABLE_PMC
@@ -2991,27 +3008,27 @@ S_doopen_pm(pTHX_ const char *name, const char *mode)
 	const char * const pmc = SvPV_nolen_const(pmcsv);
 	Stat_t pmcstat;
 	if (PerlLIO_stat(pmc, &pmcstat) < 0) {
-	    fp = PerlIO_open(name, mode);
+	    fp = check_type_and_open(aTHX_ name, mode);
 	}
 	else {
 	    Stat_t pmstat;
 	    if (PerlLIO_stat(name, &pmstat) < 0 ||
 	        pmstat.st_mtime < pmcstat.st_mtime)
 	    {
-		fp = PerlIO_open(pmc, mode);
+		fp = check_type_and_open(aTHX_ pmc, mode);
 	    }
 	    else {
-		fp = PerlIO_open(name, mode);
+		fp = check_type_and_open(aTHX_ name, mode);
 	    }
 	}
 	SvREFCNT_dec(pmcsv);
     }
     else {
-	fp = PerlIO_open(name, mode);
+	fp = check_type_and_open(aTHX_ name, mode);
     }
     return fp;
 #else
-    return PerlIO_open(name, mode);
+    return check_type_and_open(aTHX_ name, mode);
 #endif /* !PERL_DISABLE_PMC */
 }
 
diff --git a/proto.h b/proto.h
index b5dfd5b..f8b64bb 100644
--- a/proto.h
+++ b/proto.h
@@ -3285,6 +3285,11 @@ STATIC void	S_save_lines(pTHX_ AV *array, SV *sv)
 STATIC OP*	S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
 			__attribute__warn_unused_result__;
 
+STATIC PerlIO *	S_check_type_and_open(pTHX_ const char *name, const char *mode)
+			__attribute__warn_unused_result__
+			__attribute__nonnull__(pTHX_1)
+			__attribute__nonnull__(pTHX_2);
+
 STATIC PerlIO *	S_doopen_pm(pTHX_ const char *name, const char *mode)
 			__attribute__warn_unused_result__
 			__attribute__nonnull__(pTHX_1)