Add Perl_amagic_deref_call() to implement the bulk of tryAMAGICunDEREF_var().

This removes around 300 bytes of object code from each place it was previously
inlined. It also provides a better interface - quite a lot of the core
currently bodges things by creating a local variable C<SV **sp = &sv> to use
the macro.

Change the XS::APItest wrapper to amagic_deref_call().

diff --git a/embed.fnc b/embed.fnc
index 88a5ed5..22e9345 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -171,6 +171,7 @@ Anp |void   |set_context    |NN void *t
 XEop   |bool   |try_amagic_bin |int method|int flags
 XEop   |bool   |try_amagic_un  |int method|int flags
 Ap     |SV*    |amagic_call    |NN SV* left|NN SV* right|int method|int dir
+Ap     |SV *   |amagic_deref_call|NN SV *ref|int method
 Ap     |int    |Gv_AMupdate    |NN HV* stash|bool destructing
 ApR    |CV*    |gv_handler     |NULLOK HV* stash|I32 id
 Apd    |OP*    |op_append_elem |I32 optype|NULLOK OP* first|NULLOK OP* last

diff --git a/embed.h b/embed.h
index ae2db75..0d83212 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -28,6 +28,7 @@
 
 #define Gv_AMupdate(a,b)       Perl_Gv_AMupdate(aTHX_ a,b)
 #define amagic_call(a,b,c,d)   Perl_amagic_call(aTHX_ a,b,c,d)
+#define amagic_deref_call(a,b) Perl_amagic_deref_call(aTHX_ a,b)
 #define apply_attrs_string(a,b,c,d)    Perl_apply_attrs_string(aTHX_ a,b,c,d)
 #define atfork_lock            Perl_atfork_lock
 #define atfork_unlock          Perl_atfork_unlock

diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
index 51e898a..3bad328 100644 (file)
--- a/ext/XS-APItest/APItest.xs
+++ b/ext/XS-APItest/APItest.xs
@@ -916,16 +916,12 @@ INCLUDE: numeric.xs
 MODULE = XS::APItest:Overload  PACKAGE = XS::APItest::Overload
 
 SV *
-tryAMAGICunDEREF_var(sv, what)
+amagic_deref_call(sv, what)
        SV *sv
        int what
     PPCODE:
-       {
-           SV **sp = &sv;
-           tryAMAGICunDEREF_var(what);
-       }
        /* The reference is owned by something else.  */
-       PUSHs(sv);
+       PUSHs(amagic_deref_call(sv, what));
 
 MODULE = XS::APItest           PACKAGE = XS::APItest::XSUB
 

diff --git a/ext/XS-APItest/t/overload.t b/ext/XS-APItest/t/overload.t
index 1f7e52b..1c391e9 100644 (file)
--- a/ext/XS-APItest/t/overload.t
+++ b/ext/XS-APItest/t/overload.t
@@ -60,13 +60,13 @@ while (my ($type, $enum) = each %types) {
     foreach (@non_ref, @ref,
            ) {
        my ($desc, $input) = @$_;
-       my $got = tryAMAGICunDEREF_var($input, $enum);
+       my $got = amagic_deref_call($input, $enum);
        is($got, $input, "Expect no change for to_$type $desc");
     }
     foreach (@non_ref) {
        my ($desc, $sucker) = @$_;
        my $input = bless [$sucker], 'Chain';
-       is(eval {tryAMAGICunDEREF_var($input, $enum)}, undef,
+       is(eval {amagic_deref_call($input, $enum)}, undef,
             "Chain to $desc for to_$type");
        like($@, qr/Overloaded dereference did not return a reference/,
            'expected error');
@@ -75,10 +75,10 @@ while (my ($type, $enum) = each %types) {
            ) {
        my ($desc, $sucker) = @$_;
        my $input = bless [$sucker], 'Chain';
-       my $got = tryAMAGICunDEREF_var($input, $enum);
+       my $got = amagic_deref_call($input, $enum);
        is($got, $sucker, "Chain to $desc for to_$type");
        $input = bless [bless [$sucker], 'Chain'], 'Chain';
-       my $got = tryAMAGICunDEREF_var($input, $enum);
+       my $got = amagic_deref_call($input, $enum);
        is($got, $sucker, "Chain to chain to $desc for to_$type");
     }
 }

diff --git a/global.sym b/global.sym
index 8ed821e..9e37876 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -18,6 +18,7 @@
 Perl_Gv_AMupdate
 Perl_PerlIO_context_layers
 Perl_amagic_call
+Perl_amagic_deref_call
 Perl_apply_attrs_string
 Perl_atfork_lock
 Perl_atfork_unlock

diff --git a/gv.c b/gv.c
index 080db56..32b5908 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -2010,6 +2010,25 @@ Perl_try_amagic_bin(pTHX_ int method, int flags) {
     return FALSE;
 }
 
+SV *
+Perl_amagic_deref_call(pTHX_ SV *ref, int method) {
+    SV *tmpsv = NULL;
+
+    PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL;
+
+    while (SvAMAGIC(ref) && 
+          (tmpsv = amagic_call(ref, &PL_sv_undef, method,
+                               AMGf_noright | AMGf_unary))) { 
+       if (!SvROK(tmpsv))
+           Perl_croak(aTHX_ "Overloaded dereference did not return a reference");
+       if (tmpsv == ref || SvRV(tmpsv) == SvRV(ref)) {
+           /* Bail out if it returns us the same reference.  */
+           return tmpsv;
+       }
+       ref = tmpsv;
+    }
+    return tmpsv ? tmpsv : ref;
+}
 
 SV*
 Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)

diff --git a/pp.h b/pp.h
index 27f948c..3f2aea9 100644 (file)
--- a/pp.h
+++ b/pp.h
@@ -451,21 +451,8 @@ Does not use C<TARG>.  See also C<XPUSHu>, C<mPUSHu> and C<PUSHu>.
 
 #define tryAMAGICunDEREF_var(meth_enum)                                        \
     STMT_START {                                                       \
-       SV *tmpsv;                                                      \
-       SV *arg = *sp;                                                  \
-       while (SvAMAGIC(arg) &&                                         \
-              (tmpsv = amagic_call(arg, &PL_sv_undef, meth_enum,       \
-                                   AMGf_noright | AMGf_unary))) {      \
-           SPAGAIN;                                                    \
-           sv = tmpsv;                                                 \
-           if (!SvROK(tmpsv))                                          \
-               Perl_croak(aTHX_ "Overloaded dereference did not return a reference"); \
-           if (tmpsv == arg || SvRV(tmpsv) == SvRV(arg)) {             \
-               /* Bail out if it returns us the same reference.  */    \
-               break;                                                  \
-           }                                                           \
-           arg = tmpsv;                                                \
-       }                                                               \
+       sv = amagic_deref_call(aTHX_ *sp, meth_enum);                   \
+       SPAGAIN;                                                        \
     } STMT_END
 
 #define tryAMAGICunDEREF(meth) tryAMAGICunDEREF_var(CAT2(meth,_amg))

diff --git a/proto.h b/proto.h
index ffbf147..17cacb6 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -34,6 +34,11 @@ PERL_CALLCONV SV*    Perl_amagic_call(pTHX_ SV* left, SV* right, int method, int di
 #define PERL_ARGS_ASSERT_AMAGIC_CALL   \
        assert(left); assert(right)
 
+PERL_CALLCONV SV *     Perl_amagic_deref_call(pTHX_ SV *ref, int method)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL     \
+       assert(ref)
+
 PERL_CALLCONV I32      Perl_apply(pTHX_ I32 type, SV** mark, SV** sp)
                        __attribute__nonnull__(pTHX_2)
                        __attribute__nonnull__(pTHX_3);