From: David Mitchell <davem@iabyn.com>
Date: Sat, 24 Apr 2010 23:56:32 +0000 (+0100)
Subject: add Perl_magic_methcall
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=efaf36747029c85b4d8825318cb4d485a0bb350e;p=p5sagit%2Fp5-mst-13.2.git

add Perl_magic_methcall

Add a new function that wraps the setup needed to call a magic method like
FETCH (the existing S_magic_methcall function has been renamed
S_magic_methcall1).

There is one functional change, done mainly to allow for a single clean
wrapper function, and that is that the method calls are no longer wrapped
with SAVETMPS/FREETMPS. Previously only about half of them had this, so
some relied on the caller to free, some didn't. At least we're consistent
now. Doing it this way is necessary because otherwise magic_methcall()
can't return an SV (eg for POP) because it'll be a temp and get freed by
FREETMPS before it gets returned. So you'd have to copy everything, which
would slow things down.
---

diff --git a/av.c b/av.c
index 94b5f2c..a3dc4dd 100644
--- a/av.c
+++ b/av.c
@@ -74,19 +74,9 @@ Perl_av_extend(pTHX_ AV *av, I32 key)
 
     mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied);
     if (mg) {
-	dSP;
-	ENTER;
-	SAVETMPS;
-	PUSHSTACKi(PERLSI_MAGIC);
-	PUSHMARK(SP);
-	EXTEND(SP,2);
-	PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
-	mPUSHi(key + 1);
-        PUTBACK;
-	call_method("EXTEND", G_SCALAR|G_DISCARD);
-	POPSTACK;
-	FREETMPS;
-	LEAVE;
+	SV *arg1 = sv_newmortal();
+	sv_setiv(arg1, (IV)(key + 1));
+	magic_methcall(MUTABLE_SV(av), mg, "EXTEND", G_DISCARD, 1, arg1, NULL);
 	return;
     }
     if (key > AvMAX(av)) {
@@ -554,17 +544,7 @@ Perl_av_push(pTHX_ register AV *av, SV *val)
 	Perl_croak(aTHX_ "%s", PL_no_modify);
 
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
-	dSP;
-	PUSHSTACKi(PERLSI_MAGIC);
-	PUSHMARK(SP);
-	EXTEND(SP,2);
-	PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
-	PUSHs(val);
-	PUTBACK;
-	ENTER;
-	call_method("PUSH", G_SCALAR|G_DISCARD);
-	LEAVE;
-	POPSTACK;
+	magic_methcall(MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1, val, NULL);
 	return;
     }
     av_store(av,AvFILLp(av)+1,val);
@@ -592,19 +572,9 @@ Perl_av_pop(pTHX_ register AV *av)
     if (SvREADONLY(av))
 	Perl_croak(aTHX_ "%s", PL_no_modify);
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
-	dSP;    
-	PUSHSTACKi(PERLSI_MAGIC);
-	PUSHMARK(SP);
-	XPUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
-	PUTBACK;
-	ENTER;
-	if (call_method("POP", G_SCALAR)) {
-	    retval = newSVsv(*PL_stack_sp--);    
-	} else {    
-	    retval = &PL_sv_undef;
-	}
-	LEAVE;
-	POPSTACK;
+	retval = magic_methcall(MUTABLE_SV(av), mg, "POP", 0, 0, NULL, NULL);
+	if (retval)
+	    retval = newSVsv(retval);
 	return retval;
     }
     if (AvFILL(av) < 0)
@@ -662,19 +632,8 @@ Perl_av_unshift(pTHX_ register AV *av, register I32 num)
 	Perl_croak(aTHX_ "%s", PL_no_modify);
 
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
-	dSP;
-	PUSHSTACKi(PERLSI_MAGIC);
-	PUSHMARK(SP);
-	EXTEND(SP,1+num);
-	PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
-	while (num-- > 0) {
-	    PUSHs(&PL_sv_undef);
-	}
-	PUTBACK;
-	ENTER;
-	call_method("UNSHIFT", G_SCALAR|G_DISCARD);
-	LEAVE;
-	POPSTACK;
+	magic_methcall(MUTABLE_SV(av), mg, "UNSHIFT", G_DISCARD,
+	    -num, NULL, NULL);
 	return;
     }
 
@@ -734,19 +693,9 @@ Perl_av_shift(pTHX_ register AV *av)
     if (SvREADONLY(av))
 	Perl_croak(aTHX_ "%s", PL_no_modify);
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
-	dSP;
-	PUSHSTACKi(PERLSI_MAGIC);
-	PUSHMARK(SP);
-	XPUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
-	PUTBACK;
-	ENTER;
-	if (call_method("SHIFT", G_SCALAR)) {
-	    retval = newSVsv(*PL_stack_sp--);            
-	} else {    
-	    retval = &PL_sv_undef;
-	}     
-	LEAVE;
-	POPSTACK;
+	retval = magic_methcall(MUTABLE_SV(av), mg, "SHIFT", 0, 0, NULL, NULL);
+	if (retval)
+	    retval = newSVsv(retval);
 	return retval;
     }
     if (AvFILL(av) < 0)
@@ -806,19 +755,10 @@ Perl_av_fill(pTHX_ register AV *av, I32 fill)
     if (fill < 0)
 	fill = -1;
     if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) {
-	dSP;            
-	ENTER;
-	SAVETMPS;
-	PUSHSTACKi(PERLSI_MAGIC);
-	PUSHMARK(SP);
-	EXTEND(SP,2);
-	PUSHs(SvTIED_obj(MUTABLE_SV(av), mg));
-	mPUSHi(fill + 1);
-	PUTBACK;
-	call_method("STORESIZE", G_SCALAR|G_DISCARD);
-	POPSTACK;
-	FREETMPS;
-	LEAVE;
+	SV *arg1 = sv_newmortal();
+	sv_setiv(arg1, (IV)(fill + 1));
+	magic_methcall(MUTABLE_SV(av), mg, "STORESIZE", G_DISCARD,
+		1, arg1, NULL);
 	return;
     }
     if (fill <= AvMAX(av)) {
diff --git a/embed.fnc b/embed.fnc
index 1e3021c..7412f95 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -681,6 +681,9 @@ p	|int	|magic_setutf8	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_set_all_env|NN SV* sv|NN MAGIC* mg
 p	|U32	|magic_sizepack	|NN SV* sv|NN MAGIC* mg
 p	|int	|magic_wipepack	|NN SV* sv|NN MAGIC* mg
+pd	|SV*	|magic_methcall	|NN SV *sv|NN const MAGIC *mg \
+				|NN const char *meth|I32 flags \
+				|int n|NULLOK SV* arg1|NULLOK SV* arg2
 Ap	|void	|markstack_grow
 #if defined(USE_LOCALE_COLLATE)
 p	|int	|magic_setcollxfrm|NN SV* sv|NN MAGIC* mg
@@ -1489,8 +1492,9 @@ sM	|SV *	|refcounted_he_value	|NN const struct refcounted_he *he
 
 #if defined(PERL_IN_MG_C) || defined(PERL_DECL_PROT)
 s	|void	|save_magic	|I32 mgs_ix|NN SV *sv
-s	|int	|magic_methpack	|NN SV *sv|NN const MAGIC *mg|NN const char *meth
-s	|int	|magic_methcall	|NN SV *sv|NN const MAGIC *mg|NN const char *meth|I32 f \
+-s	|int	|magic_methpack	|NN SV *sv|NN const MAGIC *mg|NN const char *meth
+s	|SV*	|magic_methcall1|NN SV *sv|NN const MAGIC *mg \
+				|NN const char *meth|I32 flags \
 				|int n|NULLOK SV *val
 s	|void	|restore_magic	|NULLOK const void *p
 s	|void	|unwind_handler_stack|NN const void *p
diff --git a/embed.h b/embed.h
index 663cb6b..00fa1e0 100644
--- a/embed.h
+++ b/embed.h
@@ -511,6 +511,7 @@
 #define magic_set_all_env	Perl_magic_set_all_env
 #define magic_sizepack		Perl_magic_sizepack
 #define magic_wipepack		Perl_magic_wipepack
+#define magic_methcall		Perl_magic_methcall
 #endif
 #define markstack_grow		Perl_markstack_grow
 #if defined(USE_LOCALE_COLLATE)
@@ -1242,7 +1243,7 @@
 #ifdef PERL_CORE
 #define save_magic		S_save_magic
 #define magic_methpack		S_magic_methpack
-#define magic_methcall		S_magic_methcall
+#define magic_methcall1		S_magic_methcall1
 #define restore_magic		S_restore_magic
 #define unwind_handler_stack	S_unwind_handler_stack
 #endif
@@ -2922,6 +2923,7 @@
 #define magic_set_all_env(a,b)	Perl_magic_set_all_env(aTHX_ a,b)
 #define magic_sizepack(a,b)	Perl_magic_sizepack(aTHX_ a,b)
 #define magic_wipepack(a,b)	Perl_magic_wipepack(aTHX_ a,b)
+#define magic_methcall(a,b,c,d,e,f,g)	Perl_magic_methcall(aTHX_ a,b,c,d,e,f,g)
 #endif
 #define markstack_grow()	Perl_markstack_grow(aTHX)
 #if defined(USE_LOCALE_COLLATE)
@@ -3647,7 +3649,7 @@
 #ifdef PERL_CORE
 #define save_magic(a,b)		S_save_magic(aTHX_ a,b)
 #define magic_methpack(a,b,c)	S_magic_methpack(aTHX_ a,b,c)
-#define magic_methcall(a,b,c,d,e,f)	S_magic_methcall(aTHX_ a,b,c,d,e,f)
+#define magic_methcall1(a,b,c,d,e,f)	S_magic_methcall1(aTHX_ a,b,c,d,e,f)
 #define restore_magic(a)	S_restore_magic(aTHX_ a)
 #define unwind_handler_stack(a)	S_unwind_handler_stack(aTHX_ a)
 #endif
diff --git a/mg.c b/mg.c
index 0341f6e..24d2b98 100644
--- a/mg.c
+++ b/mg.c
@@ -1642,55 +1642,111 @@ Perl_magic_setnkeys(pTHX_ SV *sv, MAGIC *mg)
     return 0;
 }
 
-/* caller is responsible for stack switching/cleanup */
-STATIC int
-S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
+/*
+=for apidoc magic_methcall
+
+Invoke a magic method (like FETCH).
+
+* sv and mg are the tied thinggy and the tie magic;
+* meth is the name of the method to call;
+* n, arg1, arg2 are the number of args (in addition to $self) to pass to
+  the method, and the args themselves (negative n is special-cased);
+* flags:
+    G_DISCARD:     invoke method with G_DISCARD flag and don't return a value
+
+Returns the SV (if any) returned by the method, or NULL on failure.
+
+
+=cut
+*/
+
+SV*
+Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags,
+    int n, SV *arg1, SV *arg2)
 {
     dVAR;
     dSP;
+    SV* ret = NULL;
 
     PERL_ARGS_ASSERT_MAGIC_METHCALL;
 
+    ENTER;
+    PUSHSTACKi(PERLSI_MAGIC);
     PUSHMARK(SP);
-    EXTEND(SP, n);
-    PUSHs(SvTIED_obj(sv, mg));
-    if (n > 1) {
-	if (mg->mg_ptr) {
-	    if (mg->mg_len >= 0)
-		mPUSHp(mg->mg_ptr, mg->mg_len);
-	    else if (mg->mg_len == HEf_SVKEY)
-		PUSHs(MUTABLE_SV(mg->mg_ptr));
-	}
-	else if (mg->mg_type == PERL_MAGIC_tiedelem) {
-	    mPUSHi(mg->mg_len);
+
+    if (n < 0) {
+	/* special case for UNSHIFT */
+	EXTEND(SP,-n+1);
+	PUSHs(SvTIED_obj(sv, mg));
+	while (n++ < 0) {
+	    PUSHs(&PL_sv_undef);
 	}
     }
-    if (n > 2) {
-	PUSHs(val);
+    else {
+	EXTEND(SP,n+1);
+	PUSHs(SvTIED_obj(sv, mg));
+	if (n > 0) {
+	    PUSHs(arg1);
+	    if (n > 1) PUSHs(arg2);
+	    assert(n <= 2);
+	}
     }
     PUTBACK;
+    if (flags & G_DISCARD) {
+	call_method(meth, G_SCALAR|G_DISCARD);
+    }
+    else {
+	if (call_method(meth, G_SCALAR))
+	    ret = *PL_stack_sp--;
+    }
+    POPSTACK;
+    LEAVE;
+    return ret;
+}
+
+
+/* wrapper for magic_methcall that creates the first arg */
 
-    return call_method(meth, flags);
+STATIC SV*
+S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags,
+    int n, SV *val)
+{
+    dVAR;
+    SV* arg1 = NULL;
+
+    PERL_ARGS_ASSERT_MAGIC_METHCALL1;
+
+    if (mg->mg_ptr) {
+	if (mg->mg_len >= 0) {
+	    arg1 = newSVpvn(mg->mg_ptr, mg->mg_len);
+	    sv_2mortal(arg1);
+	}
+	else if (mg->mg_len == HEf_SVKEY)
+	    arg1 = MUTABLE_SV(mg->mg_ptr);
+    }
+    else if (mg->mg_type == PERL_MAGIC_tiedelem) {
+	arg1 = newSV_type(SVt_IV);
+	sv_setiv(arg1, (IV)(mg->mg_len));
+	sv_2mortal(arg1);
+    }
+    if (!arg1) {
+	arg1 = val;
+	n--;
+    }
+    return magic_methcall(sv, mg, meth, flags, n, arg1, val);
 }
 
 STATIC int
 S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
 {
-    dVAR; dSP;
+    dVAR;
+    SV* ret;
 
     PERL_ARGS_ASSERT_MAGIC_METHPACK;
 
-    ENTER;
-    SAVETMPS;
-    PUSHSTACKi(PERLSI_MAGIC);
-
-    if (magic_methcall(sv, mg, meth, G_SCALAR, 2, NULL)) {
-	sv_setsv(sv, *PL_stack_sp--);
-    }
-
-    POPSTACK;
-    FREETMPS;
-    LEAVE;
+    ret = magic_methcall1(sv, mg, meth, 0, 1, NULL);
+    if (ret)
+	sv_setsv(sv, ret);
     return 0;
 }
 
@@ -1708,7 +1764,7 @@ Perl_magic_getpack(pTHX_ SV *sv, MAGIC *mg)
 int
 Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
 {
-    dVAR; dSP;
+    dVAR;
     MAGIC *tmg;
     SV    *val;
 
@@ -1733,11 +1789,7 @@ Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg)
     else
 	val = sv;
 
-    ENTER;
-    PUSHSTACKi(PERLSI_MAGIC);
-    magic_methcall(sv, mg, "STORE", G_SCALAR|G_DISCARD, 3, val);
-    POPSTACK;
-    LEAVE;
+    magic_methcall1(sv, mg, "STORE", G_DISCARD, 2, val);
     return 0;
 }
 
@@ -1753,69 +1805,46 @@ Perl_magic_clearpack(pTHX_ SV *sv, MAGIC *mg)
 U32
 Perl_magic_sizepack(pTHX_ SV *sv, MAGIC *mg)
 {
-    dVAR; dSP;
+    dVAR;
     I32 retval = 0;
+    SV* retsv;
 
     PERL_ARGS_ASSERT_MAGIC_SIZEPACK;
 
-    ENTER;
-    SAVETMPS;
-    PUSHSTACKi(PERLSI_MAGIC);
-    if (magic_methcall(sv, mg, "FETCHSIZE", G_SCALAR, 2, NULL)) {
-	sv = *PL_stack_sp--;
-	retval = SvIV(sv)-1;
+    retsv = magic_methcall1(sv, mg, "FETCHSIZE", 0, 1, NULL);
+    if (retsv) {
+	retval = SvIV(retsv)-1;
 	if (retval < -1)
 	    Perl_croak(aTHX_ "FETCHSIZE returned a negative value");
     }
-    POPSTACK;
-    FREETMPS;
-    LEAVE;
     return (U32) retval;
 }
 
 int
 Perl_magic_wipepack(pTHX_ SV *sv, MAGIC *mg)
 {
-    dVAR; dSP;
+    dVAR;
 
     PERL_ARGS_ASSERT_MAGIC_WIPEPACK;
 
-    ENTER;
-    PUSHSTACKi(PERLSI_MAGIC);
-    PUSHMARK(SP);
-    XPUSHs(SvTIED_obj(sv, mg));
-    PUTBACK;
-    call_method("CLEAR", G_SCALAR|G_DISCARD);
-    POPSTACK;
-    LEAVE;
-
+    magic_methcall(sv, mg, "CLEAR", G_DISCARD, 0, NULL, NULL);
     return 0;
 }
 
 int
 Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
 {
-    dVAR; dSP;
-    const char * const meth = SvOK(key) ? "NEXTKEY" : "FIRSTKEY";
+    dVAR;
+    SV* ret;
 
     PERL_ARGS_ASSERT_MAGIC_NEXTPACK;
 
-    ENTER;
-    SAVETMPS;
-    PUSHSTACKi(PERLSI_MAGIC);
-    PUSHMARK(SP);
-    EXTEND(SP, 2);
-    PUSHs(SvTIED_obj(sv, mg));
-    if (SvOK(key))
-	PUSHs(key);
-    PUTBACK;
-
-    if (call_method(meth, G_SCALAR))
-	sv_setsv(key, *PL_stack_sp--);
-
-    POPSTACK;
-    FREETMPS;
-    LEAVE;
+    ret = magic_methcall(sv, mg,
+	    (SvOK(key) ? "NEXTKEY" : "FIRSTKEY"),
+	    0,
+	    (SvOK(key) ? 1 : 0), key, NULL);
+    if (ret)
+	sv_setsv(key,ret);
     return 0;
 }
 
@@ -1830,7 +1859,7 @@ Perl_magic_existspack(pTHX_ SV *sv, const MAGIC *mg)
 SV *
 Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
 {
-    dVAR; dSP;
+    dVAR;
     SV *retval;
     SV * const tied = SvTIED_obj(MUTABLE_SV(hv), mg);
     HV * const pkg = SvSTASH((const SV *)SvRV(tied));
@@ -1850,19 +1879,9 @@ Perl_magic_scalarpack(pTHX_ HV *hv, MAGIC *mg)
     }
    
     /* there is a SCALAR method that we can call */
-    ENTER;
-    PUSHSTACKi(PERLSI_MAGIC);
-    PUSHMARK(SP);
-    EXTEND(SP, 1);
-    PUSHs(tied);
-    PUTBACK;
-
-    if (call_method("SCALAR", G_SCALAR))
-        retval = *PL_stack_sp--; 
-    else
+    retval = magic_methcall(MUTABLE_SV(hv), mg, "SCALAR", 0, 0, NULL, NULL);
+    if (!retval)
 	retval = &PL_sv_undef;
-    POPSTACK;
-    LEAVE;
     return retval;
 }
 
diff --git a/proto.h b/proto.h
index 550cd5b..ad24046 100644
--- a/proto.h
+++ b/proto.h
@@ -1901,6 +1901,13 @@ PERL_CALLCONV int	Perl_magic_wipepack(pTHX_ SV* sv, MAGIC* mg)
 #define PERL_ARGS_ASSERT_MAGIC_WIPEPACK	\
 	assert(sv); assert(mg)
 
+PERL_CALLCONV SV*	Perl_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV* arg1, SV* arg2)
+			__attribute__nonnull__(pTHX_1)
+			__attribute__nonnull__(pTHX_2)
+			__attribute__nonnull__(pTHX_3);
+#define PERL_ARGS_ASSERT_MAGIC_METHCALL	\
+	assert(sv); assert(mg); assert(meth)
+
 PERL_CALLCONV void	Perl_markstack_grow(pTHX);
 #if defined(USE_LOCALE_COLLATE)
 PERL_CALLCONV int	Perl_magic_setcollxfrm(pTHX_ SV* sv, MAGIC* mg)
@@ -4481,11 +4488,11 @@ STATIC int	S_magic_methpack(pTHX_ SV *sv, const MAGIC *mg, const char *meth)
 #define PERL_ARGS_ASSERT_MAGIC_METHPACK	\
 	assert(sv); assert(mg); assert(meth)
 
-STATIC int	S_magic_methcall(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 f, int n, SV *val)
+STATIC SV*	S_magic_methcall1(pTHX_ SV *sv, const MAGIC *mg, const char *meth, I32 flags, int n, SV *val)
 			__attribute__nonnull__(pTHX_1)
 			__attribute__nonnull__(pTHX_2)
 			__attribute__nonnull__(pTHX_3);
-#define PERL_ARGS_ASSERT_MAGIC_METHCALL	\
+#define PERL_ARGS_ASSERT_MAGIC_METHCALL1	\
 	assert(sv); assert(mg); assert(meth)
 
 STATIC void	S_restore_magic(pTHX_ const void *p);