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

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

diff --git a/embed.fnc b/embed.fnc
index 1a118b1..b1346fb 100644 (file)
--- 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 4fe29c4..80457a2 100644 (file)
--- 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 0fe80b4..0d8673a 100644 (file)
--- 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 2721fac..714b3c9 100644 (file)
--- 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)