diff options
-rw-r--r-- | embed.fnc | 1 | ||||
-rw-r--r-- | embed.h | 1 | ||||
-rw-r--r-- | gv.c | 42 | ||||
-rw-r--r-- | proto.h | 3 |
4 files changed, 47 insertions, 0 deletions
@@ -635,6 +635,7 @@ XEop |bool |try_amagic_bin |int method|int flags XEop |bool |try_amagic_un |int method|int flags Apd |SV* |amagic_call |NN SV* left|NN SV* right|int method|int dir Apd |SV * |amagic_deref_call|NN SV *ref|int method +Apd |CV * |amagic_find |NN SV *sv|int method|int flags p |bool |amagic_is_enabled|int method Apd |int |Gv_AMupdate |NN HV* stash|bool destructing CpdR |CV* |gv_handler |NULLOK HV* stash|I32 id @@ -59,6 +59,7 @@ #define _utf8n_to_uvchr_msgs_helper Perl__utf8n_to_uvchr_msgs_helper #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 amagic_find(a,b,c) Perl_amagic_find(aTHX_ a,b,c) #define apply_attrs_string(a,b,c,d) Perl_apply_attrs_string(aTHX_ a,b,c,d) #define apply_builtin_cv_attributes(a,b) Perl_apply_builtin_cv_attributes(aTHX_ a,b) #define atfork_lock Perl_atfork_lock @@ -3377,6 +3377,48 @@ Perl_try_amagic_un(pTHX_ int method, int flags) { } +/* +=for apidoc amagic_find + +Check C<sv> for the overloaded (active magic) operation C<method>, and +return the C<CV *> or C<NULL>. + +C<method> is one of the values found in F<overload.h>. + +C<flags> are available for future use. + +=cut +*/ +CV * +Perl_amagic_find(pTHX_ SV *sv, int method, int flags) +{ + PERL_ARGS_ASSERT_AMAGIC_FIND; + PERL_UNUSED_VAR(flags); + + assert(method >= 0 && method < NofAMmeth); + + if (!SvAMAGIC(sv)) + return NULL; + + HV *stash = SvSTASH(SvRV(sv)); + if (!Gv_AMG(stash)) + return NULL; + + MAGIC *mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); + if (!mg) + return NULL; + + CV **cvp = NULL; + if (AMT_AMAGIC((AMT *)mg->mg_ptr)) + cvp = ((AMT *)mg->mg_ptr)->table; + if (!cvp) + return NULL; + + CV *cv = cvp[method]; + return cv; +} + + /* Implement tryAMAGICbin_MG macro. Do get magic, then see if the two stack args are overloaded and if so call it. @@ -252,6 +252,9 @@ PERL_CALLCONV SV* Perl_amagic_call(pTHX_ SV* left, SV* right, int method, int di PERL_CALLCONV SV * Perl_amagic_deref_call(pTHX_ SV *ref, int method); #define PERL_ARGS_ASSERT_AMAGIC_DEREF_CALL \ assert(ref) +PERL_CALLCONV CV * Perl_amagic_find(pTHX_ SV *sv, int method, int flags); +#define PERL_ARGS_ASSERT_AMAGIC_FIND \ + assert(sv) PERL_CALLCONV bool Perl_amagic_is_enabled(pTHX_ int method) __attribute__visibility__("hidden"); #define PERL_ARGS_ASSERT_AMAGIC_IS_ENABLED |