From: Nicholas Clark Date: Sun, 13 Jun 2010 10:12:43 +0000 (+0200) Subject: Change S_tied_handle_method() to varargs to allow extra SV parameters. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=bc0c81caab3813b2d61b70f94e5075bbf3a3ef69;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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 --- 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 --- 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)