From 8da47909ef02588ed31b30b7db5e534f747c4273 Mon Sep 17 00:00:00 2001 From: Yves Orton Date: Wed, 21 Dec 2022 13:15:25 +0100 Subject: gv.c - rename amagic_find() to amagic_applies() The api for amagic_find() didnt make as much as sense as we thought at first. Most people will be using this as a predicate, and don't care about the returned CV, so to simplify things until we can really think this through the required API this switches it to return a bool and renames it to amagic_applies(), as in "which amagic_applies to this sv". --- gv.c | 138 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 122 insertions(+), 16 deletions(-) (limited to 'gv.c') diff --git a/gv.c b/gv.c index 030ecd9123..80710647d0 100644 --- a/gv.c +++ b/gv.c @@ -3378,44 +3378,149 @@ Perl_try_amagic_un(pTHX_ int method, int flags) { /* -=for apidoc amagic_find +=for apidoc amagic_applies -Check C for the overloaded (active magic) operation C, and -return the C or C. +Check C to see if the overloaded (active magic) operation C +applies to it. If the sv is not SvROK or it is not an object then returns +false, otherwise checks if the object is blessed into a class supporting +overloaded operations, and returns true if a call to amagic_call() with +this SV and the given method would trigger an amagic operation, including +via the overload fallback rules or via nomethod. Thus a call like: -C is one of the values found in F. + amagic_applies(sv, string_amg, AMG_unary) + +would return true for an object with overloading set up in any of the +following ways: + + use overload q("") => sub { ... }; + use overload q(0+) => sub { ... }, fallback => 1; + +and could be used to tell if a given object would stringify to something +other than the normal default ref stringification. + +Note that the fact that this function returns TRUE does not mean you +can succesfully perform the operation with amagic_call(), for instance +any overloaded method might throw a fatal exception, however if this +function returns FALSE you can be confident that it will NOT perform +the given overload operation. -C are available for future use. +C is an integer enum, one of the values found in F, +for instance C. + +C should be set to AMG_unary for unary operations. =cut */ -CV * -Perl_amagic_find(pTHX_ SV *sv, int method, int flags) +bool +Perl_amagic_applies(pTHX_ SV *sv, int method, int flags) { - PERL_ARGS_ASSERT_AMAGIC_FIND; + PERL_ARGS_ASSERT_AMAGIC_APPLIES; PERL_UNUSED_VAR(flags); assert(method >= 0 && method < NofAMmeth); if (!SvAMAGIC(sv)) - return NULL; + return FALSE; HV *stash = SvSTASH(SvRV(sv)); if (!Gv_AMG(stash)) - return NULL; + return FALSE; MAGIC *mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table); if (!mg) - return NULL; + return FALSE; CV **cvp = NULL; - if (AMT_AMAGIC((AMT *)mg->mg_ptr)) - cvp = ((AMT *)mg->mg_ptr)->table; + AMT *amtp = NULL; + if (AMT_AMAGIC((AMT *)mg->mg_ptr)) { + amtp = (AMT *)mg->mg_ptr; + cvp = amtp->table; + } if (!cvp) - return NULL; + return FALSE; + + if (cvp[method]) + return TRUE; + + /* Note this logic should be kept in sync with amagic_call() */ + if (amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { + CV *cv; /* This makes it easier to kee ... */ + int off,off1; /* ... in sync with amagic_call() */ + + /* look for substituted methods */ + /* In all the covered cases we should be called with assign==0. */ + switch (method) { + case inc_amg: + if ((cv = cvp[off=add_ass_amg]) || ((cv = cvp[off = add_amg]))) + return TRUE; + break; + case dec_amg: + if((cv = cvp[off = subtr_ass_amg]) || ((cv = cvp[off = subtr_amg]))) + return TRUE; + break; + case bool__amg: + if ((cv = cvp[off=numer_amg]) || (cv = cvp[off=string_amg])) + return TRUE; + break; + case numer_amg: + if((cv = cvp[off=string_amg]) || (cv = cvp[off=bool__amg])) + return TRUE; + break; + case string_amg: + if((cv = cvp[off=numer_amg]) || (cv = cvp[off=bool__amg])) + return TRUE; + break; + case not_amg: + if((cv = cvp[off=bool__amg]) + || (cv = cvp[off=numer_amg]) + || (cv = cvp[off=string_amg])) + return TRUE; + break; + case abs_amg: + if((cvp[off1=lt_amg] || cvp[off1=ncmp_amg]) + && ((cv = cvp[off=neg_amg]) || (cv = cvp[off=subtr_amg]))) + return TRUE; + break; + case neg_amg: + if ((cv = cvp[off=subtr_amg])) + return TRUE; + break; + } + } else if (((cvp && amtp->fallback > AMGfallNEVER)) + && !(flags & AMGf_unary)) { + /* We look for substitution for + * comparison operations and + * concatenation */ + if (method==concat_amg || method==concat_ass_amg + || method==repeat_amg || method==repeat_ass_amg) { + return FALSE; /* Delegate operation to string conversion */ + } + switch (method) { + case lt_amg: + case le_amg: + case gt_amg: + case ge_amg: + case eq_amg: + case ne_amg: + if (cvp[ncmp_amg]) + return TRUE; + break; + case slt_amg: + case sle_amg: + case sgt_amg: + case sge_amg: + case seq_amg: + case sne_amg: + if (cvp[scmp_amg]) + return TRUE; + break; + } + } + + if (cvp[nomethod_amg]) + return TRUE; - CV *cv = cvp[method]; - return cv; + return FALSE; } @@ -3630,6 +3735,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) { lr = -1; /* Call method for left argument */ } else { + /* Note this logic should be kept in sync with amagic_applies() */ if (cvp && amtp->fallback > AMGfallNEVER && flags & AMGf_unary) { int logic; -- cgit v1.2.1