In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/eaab56493bda8d2c9e499f01433ea2da9b29f6e5?hp=cced55d2e366f8ccb0884e747f32c32c1b538989>
- Log ----------------------------------------------------------------- commit eaab56493bda8d2c9e499f01433ea2da9b29f6e5 Author: Yves Orton <[email protected]> Date: Thu Dec 25 01:33:42 2014 +0100 add new API function sv_get_backrefs() This encapsulates the logic to extract the backrefs from a weak-referent. Since sv_get_backrefs() can be used for a similar purposes as hv_backreferences_p() we no longer need to export the later, and therefore this patch also reverts ad2f46a793b4ade67d45ac0086ae62f6756c2752. See perl #123473 for related discussion, and https://github.com/Sereal/Sereal/issues/73 for a practical example of why this API is required. ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + embed.fnc | 3 ++- embed.h | 1 + ext/XS-APItest/APItest.xs | 19 +++++++++++++++++ ext/XS-APItest/t/weaken.t | 52 +++++++++++++++++++++++++++++++++++++++++++++++ proto.h | 6 ++++++ sv.c | 43 +++++++++++++++++++++++++++++++++++++++ 7 files changed, 124 insertions(+), 1 deletion(-) create mode 100644 ext/XS-APItest/t/weaken.t diff --git a/MANIFEST b/MANIFEST index d58ba92..ee688e6 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4003,6 +4003,7 @@ ext/XS-APItest/t/underscore_length.t Test find_rundefsv() ext/XS-APItest/t/utf16_to_utf8.t Test behaviour of utf16_to_utf8{,reversed} ext/XS-APItest/t/utf8.t Tests for code in utf8.c ext/XS-APItest/t/whichsig.t XS::APItest: tests for whichsig() and variants +ext/XS-APItest/t/weaken.t XS::APItest: tests for sv_rvweaken() and sv_get_backrefs() ext/XS-APItest/t/xs_special_subs_require.t for require too ext/XS-APItest/t/xs_special_subs.t Test that XS BEGIN/CHECK/INIT/END work ext/XS-APItest/t/xsub_h.t Tests for XSUB.h diff --git a/embed.fnc b/embed.fnc index 79e5e9a..52ec3ee 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1786,6 +1786,7 @@ Apdmb |void |sv_force_normal|NN SV *sv Apd |void |sv_force_normal_flags|NN SV *const sv|const U32 flags pX |SSize_t|tmps_grow_p |SSize_t ix Apd |SV* |sv_rvweaken |NN SV *const sv +ApPMd |SV* |sv_get_backrefs|NN SV *const sv : This is indirectly referenced by globals.c. This is somewhat annoying. p |int |magic_killbackrefs|NN SV *sv|NN MAGIC *mg Ap |OP* |newANONATTRSUB |I32 floor|NULLOK OP *proto|NULLOK OP *attrs|NULLOK OP *block @@ -2640,7 +2641,7 @@ p |void |hv_ename_add |NN HV *hv|NN const char *name|U32 len \ p |void |hv_ename_delete|NN HV *hv|NN const char *name|U32 len \ |U32 flags : Used in dump.c and hv.c -ApoM |AV** |hv_backreferences_p |NN HV *hv +poM |AV** |hv_backreferences_p |NN HV *hv #if defined(PERL_IN_DUMP_C) || defined(PERL_IN_HV_C) || defined(PERL_IN_SV_C) || defined(PERL_IN_SCOPE_C) poM |void |hv_kill_backrefs |NN HV *hv #endif diff --git a/embed.h b/embed.h index 8e71a42..c52446a 100644 --- a/embed.h +++ b/embed.h @@ -620,6 +620,7 @@ #define sv_eq_flags(a,b,c) Perl_sv_eq_flags(aTHX_ a,b,c) #define sv_force_normal_flags(a,b) Perl_sv_force_normal_flags(aTHX_ a,b) #define sv_free(a) Perl_sv_free(aTHX_ a) +#define sv_get_backrefs(a) Perl_sv_get_backrefs(aTHX_ a) #define sv_gets(a,b,c) Perl_sv_gets(aTHX_ a,b,c) #define sv_grow(a,b) Perl_sv_grow(aTHX_ a,b) #define sv_inc(a) Perl_sv_inc(aTHX_ a) diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index dee9f2f..7910635 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -5024,3 +5024,22 @@ test_Gconvert(SV * number, SV * num_digits) RETVAL = newSVpv(buffer, 0); OUTPUT: RETVAL + +MODULE = XS::APItest PACKAGE = XS::APItest::Backrefs + +void +weaken(SV *sv) + PROTOTYPE: $ + CODE: + sv_rvweaken(sv); + +SV * +has_backrefs(SV *sv) + CODE: + if (SvROK(sv) && sv_get_backrefs(SvRV(sv))) + RETVAL = &PL_sv_yes; + else + RETVAL = &PL_sv_no; + OUTPUT: + RETVAL + diff --git a/ext/XS-APItest/t/weaken.t b/ext/XS-APItest/t/weaken.t new file mode 100644 index 0000000..5396e52 --- /dev/null +++ b/ext/XS-APItest/t/weaken.t @@ -0,0 +1,52 @@ +#!perl + +use strict; +use warnings; + +use Test::More tests => 7; + +use_ok('XS::APItest'); + +# test sv_rvweaken() and sv_get_backrefs() +# +# weaken() maps to sv_rvweaken() and is the same as the one +# from Scalar::Utils - we recreate it in XS::APItest so +# we can test it even if we build without Scalar::Utils +# +# has_backrefs() maps to sv_get_backrefs(), which would not +# normally be useful to Perl code. (Er, maybe :-) + +# has_backrefs is really an internal routine +# which would not normally have to worry about refs +# and things like that, but to use it from perl we cant +# have an AV/HV without having an RV wrapping it, so we +# mandate the ref always. + +my $foo= "foo"; +my $bar= "bar"; + +my $scalar_ref= \$foo; +my $array_ref= [ qw(this is an array) ]; +my $hash_ref= { this => is => a => 'hash' }; + +my $nrml_scalar_ref= \$bar; +my $nrml_array_ref= [ qw( this is an array ) ]; +my $nrml_hash_ref= { this => is => a => 'hash' }; + +# we could probably do other tests here, such as +# verify the refcount of the referents, but maybe +# another day. +weaken(my $weak_scalar_ref= $scalar_ref); +weaken(my $weak_array_ref= $array_ref); +weaken(my $weak_hash_ref= $hash_ref); + +ok(has_backrefs($scalar_ref), "scalar with backrefs"); +ok(has_backrefs($array_ref), "array with backrefs"); +ok(has_backrefs($hash_ref), "hash with backrefs"); + +ok(!has_backrefs($nrml_scalar_ref), "scalar without backrefs"); +ok(!has_backrefs($nrml_array_ref), "array without backrefs"); +ok(!has_backrefs($nrml_hash_ref), "hash without backrefs"); + +1; + diff --git a/proto.h b/proto.h index ce86fca..c27e50b 100644 --- a/proto.h +++ b/proto.h @@ -4379,6 +4379,12 @@ PERL_CALLCONV void Perl_sv_free2(pTHX_ SV *const sv, const U32 refcnt) assert(sv) PERL_CALLCONV void Perl_sv_free_arenas(pTHX); +PERL_CALLCONV SV* Perl_sv_get_backrefs(pTHX_ SV *const sv) + __attribute__pure__ + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_SV_GET_BACKREFS \ + assert(sv) + PERL_CALLCONV char* Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) __attribute__nonnull__(pTHX_1) __attribute__nonnull__(pTHX_2); diff --git a/sv.c b/sv.c index 65acdee..2bbd55b 100644 --- a/sv.c +++ b/sv.c @@ -5929,6 +5929,49 @@ Perl_sv_rvweaken(pTHX_ SV *const sv) return sv; } +/* +=for apidoc sv_get_backrefs + +If the sv is the target of a weakrefence then return +the backrefs structure associated with the sv, otherwise +return NULL. + +When returning a non-null result the type of the return +is relevant. If it is an AV then the contents of the AV +are the weakrefs which point at this item. If it is any +other type then the item itself is the weakref. + +See also Perl_sv_add_backref(), Perl_sv_del_backref(), +Perl_sv_kill_backrefs() + +=cut +*/ + +SV * +Perl_sv_get_backrefs(pTHX_ SV *const sv) +{ + SV **svp= NULL; + MAGIC *mg = NULL; + + PERL_ARGS_ASSERT_SV_GET_BACKREFS; + + /* find slot to store array or singleton backref */ + + if (SvTYPE(sv) == SVt_PVHV) { + if (SvOOK(sv)) + svp = (SV**)Perl_hv_backreferences_p(aTHX_ sv); + } else { + if (SvMAGICAL(sv)) + mg = mg_find(sv, PERL_MAGIC_backref); + if (mg) + svp = &(mg->mg_obj); + } + if (svp) + return *svp; + else + return NULL; +} + /* Give tsv backref magic if it hasn't already got it, then push a * back-reference to sv onto the array associated with the backref magic. * -- Perl5 Master Repository
