diff options
| -rw-r--r-- | embed.fnc | 6 | ||||
| -rw-r--r-- | embed.h | 3 | ||||
| -rw-r--r-- | pp.h | 8 | ||||
| -rw-r--r-- | pp_sys.c | 87 | ||||
| -rw-r--r-- | proto.h | 16 |
5 files changed, 63 insertions, 57 deletions
@@ -1723,10 +1723,10 @@ 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 -so |OP * |tied_handle_method|NN const char *const methname|NN SV **sp \ - |NN IO *const io|NN const MAGIC *const mg \ - |const U32 flags|U32 argc|... #endif +p |OP * |tied_method|NN const char *const methname|NN SV **sp \ + |NN SV *const sv|NN const MAGIC *const mg \ + |const U32 flags|U32 argc|... #if defined(PERL_IN_REGCOMP_C) Es |regnode*|reg |NN struct RExC_state_t *pRExC_state \ @@ -1480,6 +1480,9 @@ #define sv_clean_objs() Perl_sv_clean_objs(aTHX) #define sv_del_backref(a,b) Perl_sv_del_backref(aTHX_ a,b) #define sv_free_arenas() Perl_sv_free_arenas(aTHX) +#ifndef PERL_IMPLICIT_CONTEXT +#define tied_method Perl_tied_method +#endif #define unshare_hek(a) Perl_unshare_hek(aTHX_ a) #define vivify_ref(a,b) Perl_vivify_ref(aTHX_ a,b) #define wait4pid(a,b,c) Perl_wait4pid(aTHX_ a,b,c) @@ -491,6 +491,14 @@ True if this op will be the return value of an lvalue subroutine ) \ ) +#ifdef PERL_CORE +/* These are just for Perl_tied_method(), which is not part of the public API. + Use 0x04 rather than the next available bit, to help the compiler if the + architecture can generate more efficient instructions. */ +# define TIED_METHOD_MORTALIZE_NOT_NEEDED 0x04 +# define TIED_METHOD_ARGUMENTS_ON_STACK 0x08 +#endif + /* * Local variables: * c-indentation-style: bsd @@ -507,29 +507,23 @@ PP(pp_die) /* I/O. */ -/* These are private to this function, which is private to this file. - Use 0x04 rather than the next available bit, to help the compiler if the - architecture can generate more efficient instructions. */ -#define MORTALIZE_NOT_NEEDED 0x04 -#define ARGUMENTS_ON_STACK 0x08 - -static OP * -S_tied_handle_method(pTHX_ const char *const methname, SV **sp, - IO *const io, const MAGIC *const mg, const U32 flags, - U32 argc, ...) +OP * +Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv, + const MAGIC *const mg, const U32 flags, U32 argc, ...) { - PERL_ARGS_ASSERT_TIED_HANDLE_METHOD; + PERL_ARGS_ASSERT_TIED_METHOD; /* Ensure that our flag bits do not overlap. */ - assert((MORTALIZE_NOT_NEEDED & G_WANT) == 0); - assert((ARGUMENTS_ON_STACK & G_WANT) == 0); + assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0); + assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0); PUSHMARK(sp); - PUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); - if (flags & ARGUMENTS_ON_STACK) + PUSHs(SvTIED_obj(sv, mg)); + if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) sp += argc; else if (argc) { - const U32 mortalize_not_needed = flags & MORTALIZE_NOT_NEEDED; + const U32 mortalize_not_needed + = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED; va_list args; va_start(args, argc); do { @@ -543,18 +537,18 @@ S_tied_handle_method(pTHX_ const char *const methname, SV **sp, } PUTBACK; - ENTER_with_name("call_tied_handle_method"); + ENTER_with_name("call_tied_method"); call_method(methname, flags & G_WANT); - LEAVE_with_name("call_tied_handle_method"); + LEAVE_with_name("call_tied_method"); return NORMAL; } -#define tied_handle_method0(a,b,c,d) \ - S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR,0) -#define tied_handle_method1(a,b,c,d,e) \ - S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR,1,e) -#define tied_handle_method2(a,b,c,d,e,f) \ - S_tied_handle_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f) +#define tied_method0(a,b,c,d) \ + Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,0) +#define tied_method1(a,b,c,d,e) \ + Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,1,e) +#define tied_method2(a,b,c,d,e,f) \ + Perl_tied_method(aTHX_ a,b,c,d,G_SCALAR,2,e,f) PP(pp_open) { @@ -585,9 +579,9 @@ PP(pp_open) if (mg) { /* Method's args are same as ours ... */ /* ... except handle is replaced by the object */ - return S_tied_handle_method(aTHX_ "OPEN", mark - 1, io, mg, - G_SCALAR | ARGUMENTS_ON_STACK, - sp - mark); + return Perl_tied_method(aTHX_ "OPEN", mark - 1, MUTABLE_SV(io), mg, + G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, + sp - mark); } } @@ -623,7 +617,7 @@ PP(pp_close) if (io) { const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - return tied_handle_method0("CLOSE", SP, io, mg); + return tied_method0("CLOSE", SP, MUTABLE_SV(io), mg); } } } @@ -706,7 +700,7 @@ PP(pp_fileno) if (io && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { - return tied_handle_method0("FILENO", SP, io, mg); + return tied_method0("FILENO", SP, MUTABLE_SV(io), mg); } if (!io || !(fp = IoIFP(io))) { @@ -777,9 +771,9 @@ PP(pp_binmode) 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, - G_SCALAR|MORTALIZE_NOT_NEEDED, - discp ? 1 : 0, discp); + return Perl_tied_method(aTHX_ "BINMODE", SP, MUTABLE_SV(io), mg, + G_SCALAR|TIED_METHOD_MORTALIZE_NOT_NEEDED, + discp ? 1 : 0, discp); } } @@ -1261,7 +1255,7 @@ PP(pp_getc) const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { const U32 gimme = GIMME_V; - S_tied_handle_method(aTHX_ "GETC", SP, io, mg, gimme, 0); + Perl_tied_method(aTHX_ "GETC", SP, MUTABLE_SV(io), mg, gimme, 0); if (gimme == G_SCALAR) { SPAGAIN; SvSetMagicSV_nosteal(TARG, TOPs); @@ -1507,9 +1501,10 @@ PP(pp_prtf) Move(MARK, MARK + 1, (SP - MARK) + 1, SV*); ++SP; } - return S_tied_handle_method(aTHX_ "PRINTF", mark - 1, io, mg, - G_SCALAR | ARGUMENTS_ON_STACK, - sp - mark); + return Perl_tied_method(aTHX_ "PRINTF", mark - 1, MUTABLE_SV(io), + mg, + G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, + sp - mark); } } @@ -1599,9 +1594,9 @@ PP(pp_sysread) { const MAGIC *const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - return S_tied_handle_method(aTHX_ "READ", mark - 1, io, mg, - G_SCALAR | ARGUMENTS_ON_STACK, - sp - mark); + return Perl_tied_method(aTHX_ "READ", mark - 1, MUTABLE_SV(io), mg, + G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, + sp - mark); } } @@ -1844,9 +1839,9 @@ PP(pp_send) PUTBACK; } - return S_tied_handle_method(aTHX_ "WRITE", mark - 1, io, mg, - G_SCALAR | ARGUMENTS_ON_STACK, - sp - mark); + return Perl_tied_method(aTHX_ "WRITE", mark - 1, MUTABLE_SV(io), mg, + G_SCALAR | TIED_METHOD_ARGUMENTS_ON_STACK, + sp - mark); } } if (!gv) @@ -2066,7 +2061,7 @@ PP(pp_eof) RETPUSHNO; if ((io = GvIO(gv)) && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { - return tied_handle_method1("EOF", SP, io, mg, newSVuv(which)); + return tied_method1("EOF", SP, MUTABLE_SV(io), mg, newSVuv(which)); } if (!MAXARG && (PL_op->op_flags & OPf_SPECIAL)) { /* eof() */ @@ -2106,7 +2101,7 @@ PP(pp_tell) if (io) { const MAGIC * const mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar); if (mg) { - return tied_handle_method0("TELL", SP, io, mg); + return tied_method0("TELL", SP, MUTABLE_SV(io), mg); } } else if (!gv) { @@ -2146,8 +2141,8 @@ PP(pp_sysseek) SV *const offset_sv = newSViv(offset); #endif - return tied_handle_method2("SEEK", SP, io, mg, offset_sv, - newSViv(whence)); + return tied_method2("SEEK", SP, MUTABLE_SV(io), mg, offset_sv, + newSViv(whence)); } } @@ -4548,6 +4548,14 @@ PERL_CALLCONV void Perl_taint_proper(pTHX_ const char* f, const char *const s) #define PERL_ARGS_ASSERT_TAINT_PROPER \ assert(s) +PERL_CALLCONV OP * Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv, const MAGIC *const mg, const U32 flags, U32 argc, ...) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_3) + __attribute__nonnull__(pTHX_4); +#define PERL_ARGS_ASSERT_TIED_METHOD \ + assert(methname); assert(sp); assert(sv); assert(mg) + PERL_CALLCONV void Perl_tmps_grow(pTHX_ I32 n); PERL_CALLCONV UV Perl_to_uni_fold(pTHX_ UV c, U8 *p, STRLEN *lenp) __attribute__nonnull__(pTHX_2) @@ -6261,14 +6269,6 @@ 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, const MAGIC *const mg, const U32 flags, U32 argc, ...) - __attribute__nonnull__(pTHX_1) - __attribute__nonnull__(pTHX_2) - __attribute__nonnull__(pTHX_3) - __attribute__nonnull__(pTHX_4); -#define PERL_ARGS_ASSERT_TIED_HANDLE_METHOD \ - assert(methname); assert(sp); assert(io); assert(mg) - #endif #if defined(PERL_IN_REGCOMP_C) STATIC U32 S_add_data(struct RExC_state_t *pRExC_state, U32 n, const char *s) |