summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--embed.fnc6
-rw-r--r--embed.h3
-rw-r--r--pp.h8
-rw-r--r--pp_sys.c87
-rw-r--r--proto.h16
5 files changed, 63 insertions, 57 deletions
diff --git a/embed.fnc b/embed.fnc
index fee18cea7d..bdf8cb925e 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -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 \
diff --git a/embed.h b/embed.h
index e393a01739..54b7c68cc3 100644
--- a/embed.h
+++ b/embed.h
@@ -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)
diff --git a/pp.h b/pp.h
index f3368f76e6..3070476fc9 100644
--- a/pp.h
+++ b/pp.h
@@ -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
diff --git a/pp_sys.c b/pp_sys.c
index f8f1b5b426..a0ed985de5 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -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));
}
}
diff --git a/proto.h b/proto.h
index 86337af584..5667a5e9ce 100644
--- a/proto.h
+++ b/proto.h
@@ -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)
View Lorry Controller Status