diff options
| -rw-r--r-- | embed.fnc | 1 | ||||
| -rw-r--r-- | embed.h | 1 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.xs | 8 | ||||
| -rw-r--r-- | ext/XS-APItest/t/overload.t | 8 | ||||
| -rw-r--r-- | global.sym | 1 | ||||
| -rw-r--r-- | gv.c | 19 | ||||
| -rw-r--r-- | pp.h | 17 | ||||
| -rw-r--r-- | proto.h | 5 |
8 files changed, 35 insertions, 25 deletions
@@ -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 @@ -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 51e898a4d2..3bad3286f2 100644 --- 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 1f7e52b8b1..1c391e9701 100644 --- 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 8ed821e915..9e37876aab 100644 --- 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 @@ -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) @@ -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)) @@ -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); |