Double magic/warnings with binmode $fh, undef

From: "Vincent Pit" <perl@profvince.com>
Message-ID: <63615.92.128.97.94.1209490401.squirrel@92.128.97.94>

p4raw-id: //depot/perl@33766

7 files changed, 17 insertions, 12 deletions

diff --git a/doio.c b/doio.c
index 6b0c9f2840..b73f127a1e 100644
--- a/doio.c
+++ b/doio.c
@@ -1096,12 +1096,10 @@ Perl_do_sysseek(pTHX_ GV *gv, Off_t pos, int whence)
 }
 
 int
-Perl_mode_from_discipline(pTHX_ SV *discp)
+Perl_mode_from_discipline(pTHX_ const char *s, STRLEN len)
 {
     int mode = O_BINARY;
-    if (discp) {
-	STRLEN len;
-	const char *s = SvPV_const(discp,len);
+    if (s) {
 	while (*s) {
 	    if (*s == ':') {
 		switch (s[1]) {
diff --git a/embed.fnc b/embed.fnc
index 48bddee9a8..43fe830c0f 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -525,7 +525,7 @@ Apd	|int	|mg_set		|NN SV* sv
 Ap	|I32	|mg_size	|NN SV* sv
 Ap	|void	|mini_mktime	|NN struct tm *ptm
 EXp	|OP*	|mod		|NULLOK OP* o|I32 type
-p	|int	|mode_from_discipline|NULLOK SV* discp
+p	|int	|mode_from_discipline|NULLOK const char* s|STRLEN len
 Ap	|const char*	|moreswitches	|NN const char* s
 p	|OP*	|my		|NN OP* o
 Ap	|NV	|my_atof	|NN const char *s
diff --git a/embed.h b/embed.h
index ba4899bdca..6d4e489140 100644
--- a/embed.h
+++ b/embed.h
@@ -2801,7 +2801,7 @@
 #define mod(a,b)		Perl_mod(aTHX_ a,b)
 #endif
 #ifdef PERL_CORE
-#define mode_from_discipline(a)	Perl_mode_from_discipline(aTHX_ a)
+#define mode_from_discipline(a,b)	Perl_mode_from_discipline(aTHX_ a,b)
 #endif
 #define moreswitches(a)		Perl_moreswitches(aTHX_ a)
 #ifdef PERL_CORE
diff --git a/op.c b/op.c
index 60c1b77a22..dc58747223 100644
--- a/op.c
+++ b/op.c
@@ -7415,7 +7415,9 @@ Perl_ck_open(pTHX_ OP *o)
     if (table) {
 	SV **svp = hv_fetchs(table, "open_IN", FALSE);
 	if (svp && *svp) {
-	    const I32 mode = mode_from_discipline(*svp);
+	    STRLEN len = 0;
+	    const char *d = SvPV_const(*svp, len);
+	    const I32 mode = mode_from_discipline(d, len);
 	    if (mode & O_BINARY)
 		o->op_private |= OPpOPEN_IN_RAW;
 	    else if (mode & O_TEXT)
@@ -7424,7 +7426,9 @@ Perl_ck_open(pTHX_ OP *o)
 
 	svp = hv_fetchs(table, "open_OUT", FALSE);
 	if (svp && *svp) {
-	    const I32 mode = mode_from_discipline(*svp);
+	    STRLEN len = 0;
+	    const char *d = SvPV_const(*svp, len);
+	    const I32 mode = mode_from_discipline(d, len);
 	    if (mode & O_BINARY)
 		o->op_private |= OPpOPEN_OUT_RAW;
 	    else if (mode & O_TEXT)
diff --git a/pp_sys.c b/pp_sys.c
index 59439e9f17..94549ed48d 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -762,8 +762,12 @@ PP(pp_binmode)
 
     PUTBACK;
     {
-	const int mode = mode_from_discipline(discp);
-	const char *const d = (discp ? SvPV_nolen_const(discp) : NULL);
+	STRLEN len = 0;
+	const char *d = NULL;
+	int mode;
+	if (discp)
+	    d = SvPV_const(discp, len);
+	mode = mode_from_discipline(d, len);
 	if (PerlIO_binmode(aTHX_ fp, IoTYPE(io), mode, d)) {
 	    if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
 		if (!PerlIO_binmode(aTHX_ IoOFP(io), IoTYPE(io), mode, d)) {
diff --git a/proto.h b/proto.h
index cba5fa13fd..e40cdcfaeb 100644
--- a/proto.h
+++ b/proto.h
@@ -1885,7 +1885,7 @@ PERL_CALLCONV void	Perl_mini_mktime(pTHX_ struct tm *ptm)
 	assert(ptm)
 
 PERL_CALLCONV OP*	Perl_mod(pTHX_ OP* o, I32 type);
-PERL_CALLCONV int	Perl_mode_from_discipline(pTHX_ SV* discp);
+PERL_CALLCONV int	Perl_mode_from_discipline(pTHX_ const char* s, STRLEN len);
 PERL_CALLCONV const char*	Perl_moreswitches(pTHX_ const char* s)
 			__attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_MORESWITCHES	\
diff --git a/t/lib/warnings/9uninit b/t/lib/warnings/9uninit
index 09bd371c04..ffa69d852c 100644
--- a/t/lib/warnings/9uninit
+++ b/t/lib/warnings/9uninit
@@ -1125,7 +1125,6 @@ Use of uninitialized value $m1 in sysopen at - line 16.
 Use of uninitialized value $m1 in umask at - line 19.
 Use of uninitialized value $g1 in umask at - line 20.
 Use of uninitialized value $m1 in binmode at - line 23.
-Use of uninitialized value $m1 in binmode at - line 23.
 ########
 use warnings 'uninitialized';
 my ($m1);