Change S_tied_handle_method() to varargs to allow extra SV parameters.

This enables "BINMODE", "EOF" and "SYSSEEK" to use it.

4 files changed, 55 insertions, 51 deletions

diff --git a/embed.fnc b/embed.fnc
index 1a118b1903..b1346fbeda 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -1716,8 +1716,9 @@ s	|OP*	|doform		|NN CV *cv|NN GV *gv|NN OP *retop
 sR	|int	|dooneliner	|NN const char *cmd|NN const char *filename
 #  endif
 s	|SV *	|space_join_names_mortal|NN char *const *array
-s	|OP *	|tied_handle_method|NN const char *const methname|NN SV **sp \
-				|NN IO *const io|NN MAGIC *const mg
+so	|OP *	|tied_handle_method|NN const char *const methname|NN SV **sp \
+				|NN IO *const io|NN MAGIC *const mg \
+				|unsigned int argc|...
 #endif
 
 #if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT)
diff --git a/embed.h b/embed.h
index 4fe29c45e8..80457a2ec5 100644
--- a/embed.h
+++ b/embed.h
@@ -1455,7 +1455,6 @@
 #  endif
 #ifdef PERL_CORE
 #define space_join_names_mortal	S_space_join_names_mortal
-#define tied_handle_method	S_tied_handle_method
 #endif
 #endif
 #if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT)
@@ -3896,7 +3895,6 @@
 #  endif
 #ifdef PERL_CORE
 #define space_join_names_mortal(a)	S_space_join_names_mortal(aTHX_ a)
-#define tied_handle_method(a,b,c,d)	S_tied_handle_method(aTHX_ a,b,c,d)
 #endif
 #endif
 #if defined(PERL_IN_REGCOMP_C) || defined(PERL_DECL_PROT)
diff --git a/pp_sys.c b/pp_sys.c
index 0fe80b4681..0d8673ae4f 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -554,12 +554,22 @@ PP(pp_open)
 
 static OP *
 S_tied_handle_method(pTHX_ const char *const methname, SV **sp,
-		     IO *const io, MAGIC *const mg)
+		     IO *const io, MAGIC *const mg, unsigned int argc, ...)
 {
     PERL_ARGS_ASSERT_TIED_HANDLE_METHOD;
 
     PUSHMARK(sp);
     PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
+    if (argc) {
+	va_list args;
+	va_start(args, argc);
+	do {
+	    SV *const arg = va_arg(args, SV *);
+	    PUSHs(arg);
+	} while (--argc);
+	va_end(args);
+    }
+
     PUTBACK;
     ENTER_with_name("call_tied_handle_method");
     call_method(methname, G_SCALAR);
@@ -567,6 +577,13 @@ S_tied_handle_method(pTHX_ const char *const methname, SV **sp,
     return NORMAL;
 }
 
+#define tied_handle_method(a,b,c,d)		\
+    S_tied_handle_method(aTHX_ a,b,c,d,0)
+#define tied_handle_method1(a,b,c,d,e)	\
+    S_tied_handle_method(aTHX_ a,b,c,d,1,e)
+#define tied_handle_method2(a,b,c,d,e,f)	\
+    S_tied_handle_method(aTHX_ a,b,c,d,2,e,f)
+
 PP(pp_close)
 {
     dVAR; dSP;
@@ -729,16 +746,12 @@ PP(pp_binmode)
     if (gv && (io = GvIO(gv))) {
 	MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
 	if (mg) {
-	    PUSHMARK(SP);
-	    PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
-	    if (discp)
-		PUSHs(discp);
-	    PUTBACK;
-	    ENTER_with_name("call_BINMODE");
-	    call_method("BINMODE", G_SCALAR);
-	    LEAVE_with_name("call_BINMODE");
-	    SPAGAIN;
-	    RETURN;
+	    /* This takes advantage of the implementation of the varargs
+	       function, which I don't think that the optimiser will be able to
+	       figure out. Although, as it's a static function, in theory it
+	       could.  */
+	    return S_tied_handle_method(aTHX_ "BINMODE", SP, io, mg,
+					discp ? 1 : 0, discp);
 	}
     }
 
@@ -2010,43 +2023,41 @@ PP(pp_eof)
     GV *gv;
     IO *io;
     MAGIC *mg;
+    /*
+     * in Perl 5.12 and later, the additional parameter is a bitmask:
+     * 0 = eof
+     * 1 = eof(FH)
+     * 2 = eof()  <- ARGV magic
+     *
+     * I'll rely on the compiler's trace flow analysis to decide whether to
+     * actually assign this out here, or punt it into the only block where it is
+     * used. Doing it out here is DRY on the condition logic.
+     */
+    unsigned int which;
 
-    if (MAXARG)
+    if (MAXARG) {
 	gv = PL_last_in_gv = MUTABLE_GV(POPs);	/* eof(FH) */
+	which = 1;
+    }
     else {
 	EXTEND(SP, 1);
 
-	if (PL_op->op_flags & OPf_SPECIAL)
+	if (PL_op->op_flags & OPf_SPECIAL) {
 	    gv = PL_last_in_gv = GvEGVx(PL_argvgv);	/* eof() - ARGV magic */
-	else
+	    which = 2;
+	}
+	else {
 	    gv = PL_last_in_gv;			/* eof */
+	    which = 0;
+	}
     }
 
     if (!gv)
 	RETPUSHNO;
 
     if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) {
-	PUSHMARK(SP);
-	PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
-	/*
-	 * in Perl 5.12 and later, the additional paramter is a bitmask:
-	 * 0 = eof
-	 * 1 = eof(FH)
-	 * 2 = eof()  <- ARGV magic
-	 */
-	EXTEND(SP, 1);
-	if (MAXARG)
-	    mPUSHi(1);		/* 1 = eof(FH) - simple, explicit FH */
-	else if (PL_op->op_flags & OPf_SPECIAL)
-	    mPUSHi(2);		/* 2 = eof()   - ARGV magic */
-	else
-	    mPUSHi(0);		/* 0 = eof     - simple, implicit FH */
-	PUTBACK;
-	ENTER;
-	call_method("EOF", G_SCALAR);
-	LEAVE;
-	SPAGAIN;
-	RETURN;
+	return tied_handle_method1("EOF", SP, io, mg,
+				   sv_2mortal(newSVuv(which)));
     }
 
     if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) {	/* eof() */
@@ -2119,20 +2130,14 @@ PP(pp_sysseek)
     if (gv && (io = GvIO(gv))) {
 	MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar);
 	if (mg) {
-	    PUSHMARK(SP);
-	    PUSHs(SvTIED_obj(MUTABLE_SV(io), mg));
 #if LSEEKSIZE > IVSIZE
-	    mPUSHn((NV) offset);
+	    SV *const offset_sv = sv_2mortal(newSVnv((NV) offset));
 #else
-	    mPUSHi(offset);
+	    SV *const offset_sv = sv_2mortal(newSViv(offset));
 #endif
-	    mPUSHi(whence);
-	    PUTBACK;
-	    ENTER;
-	    call_method("SEEK", G_SCALAR);
-	    LEAVE;
-	    SPAGAIN;
-	    RETURN;
+
+	    return tied_handle_method2("SEEK", SP, io, mg, offset_sv,
+				       sv_2mortal(newSViv(whence)));
 	}
     }
 
diff --git a/proto.h b/proto.h
index 2721faccfa..714b3c9d8c 100644
--- a/proto.h
+++ b/proto.h
@@ -5350,7 +5350,7 @@ STATIC SV *	S_space_join_names_mortal(pTHX_ char *const *array)
 #define PERL_ARGS_ASSERT_SPACE_JOIN_NAMES_MORTAL	\
 	assert(array)
 
-STATIC OP *	S_tied_handle_method(pTHX_ const char *const methname, SV **sp, IO *const io, MAGIC *const mg)
+STATIC OP *	S_tied_handle_method(pTHX_ const char *const methname, SV **sp, IO *const io, MAGIC *const mg, unsigned int argc, ...)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2)
 			__attribute__nonnull__(pTHX_3)