+OP *
+Perl_tied_method(pTHX_ const char *const methname, SV **sp, SV *const sv,
+ const MAGIC *const mg, const U32 flags, U32 argc, ...)
+{
+ SV **orig_sp = sp;
+ I32 ret_args;
+
+ PERL_ARGS_ASSERT_TIED_METHOD;
+
+ /* Ensure that our flag bits do not overlap. */
+ assert((TIED_METHOD_MORTALIZE_NOT_NEEDED & G_WANT) == 0);
+ assert((TIED_METHOD_ARGUMENTS_ON_STACK & G_WANT) == 0);
+ assert((TIED_METHOD_SAY & G_WANT) == 0);
+
+ PUTBACK; /* sp is at *foot* of args, so this pops args from old stack */
+ PUSHSTACKi(PERLSI_MAGIC);
+ EXTEND(SP, argc+1); /* object + args */
+ PUSHMARK(sp);
+ PUSHs(SvTIED_obj(sv, mg));
+ if (flags & TIED_METHOD_ARGUMENTS_ON_STACK) {
+ Copy(orig_sp + 2, sp + 1, argc, SV*); /* copy args to new stack */
+ sp += argc;
+ }
+ else if (argc) {
+ const U32 mortalize_not_needed
+ = flags & TIED_METHOD_MORTALIZE_NOT_NEEDED;
+ va_list args;
+ va_start(args, argc);
+ do {
+ SV *const arg = va_arg(args, SV *);
+ if(mortalize_not_needed)
+ PUSHs(arg);
+ else
+ mPUSHs(arg);
+ } while (--argc);
+ va_end(args);
+ }
+
+ PUTBACK;
+ ENTER_with_name("call_tied_method");
+ if (flags & TIED_METHOD_SAY) {
+ /* local $\ = "\n" */
+ SAVEGENERICSV(PL_ors_sv);
+ PL_ors_sv = newSVpvs("\n");
+ }
+ ret_args = call_method(methname, flags & G_WANT);
+ SPAGAIN;
+ orig_sp = sp;
+ POPSTACK;
+ SPAGAIN;
+ if (ret_args) { /* copy results back to original stack */
+ EXTEND(sp, ret_args);
+ Copy(orig_sp - ret_args + 1, sp + 1, ret_args, SV*);
+ sp += ret_args;
+ PUTBACK;
+ }
+ LEAVE_with_name("call_tied_method");
+ return NORMAL;
+}
+
+#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)
+