diff options
| -rw-r--r-- | embed.fnc | 2 | ||||
| -rw-r--r-- | embed.h | 2 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.pm | 2 | ||||
| -rw-r--r-- | ext/XS-APItest/APItest.xs | 12 | ||||
| -rw-r--r-- | ext/XS-APItest/t/overload.t | 61 | ||||
| -rw-r--r-- | gv.c | 138 | ||||
| -rw-r--r-- | proto.h | 6 |
7 files changed, 201 insertions, 22 deletions
@@ -635,7 +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 +Xpd |bool |amagic_applies |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,7 +59,6 @@ #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 @@ -1234,6 +1233,7 @@ #define abort_execution(a,b) Perl_abort_execution(aTHX_ a,b) #define alloc_LOGOP(a,b,c) Perl_alloc_LOGOP(aTHX_ a,b,c) #define allocmy(a,b,c) Perl_allocmy(aTHX_ a,b,c) +#define amagic_applies(a,b,c) Perl_amagic_applies(aTHX_ a,b,c) #define amagic_is_enabled(a) Perl_amagic_is_enabled(aTHX_ a) #define apply(a,b,c) Perl_apply(aTHX_ a,b,c) #define av_extend_guts(a,b,c,d,e) Perl_av_extend_guts(aTHX_ a,b,c,d,e) diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm index f3f3edacf1..821ca6530a 100644 --- a/ext/XS-APItest/APItest.pm +++ b/ext/XS-APItest/APItest.pm @@ -4,7 +4,7 @@ use strict; use warnings; use Carp; -our $VERSION = '1.28'; +our $VERSION = '1.29'; require XSLoader; diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 585d6b38de..54b9094fb9 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -1717,6 +1717,18 @@ test_uvchr_to_utf8_flags_msgs(uv, flags) MODULE = XS::APItest:Overload PACKAGE = XS::APItest::Overload void +does_amagic_apply(sv, method, flags) + SV *sv + int method + int flags + PPCODE: + if(Perl_amagic_applies(aTHX_ sv, method, flags)) + XSRETURN_YES; + else + XSRETURN_NO; + + +void amagic_deref_call(sv, what) SV *sv int what diff --git a/ext/XS-APItest/t/overload.t b/ext/XS-APItest/t/overload.t index e83144b7b1..53f4485e4b 100644 --- a/ext/XS-APItest/t/overload.t +++ b/ext/XS-APItest/t/overload.t @@ -88,4 +88,65 @@ while (my ($type, $enum) = each %types) { } } +{ + package String; + use overload q("")=>sub { return $_[0]->val }; + sub is_string_amg { 1 } + sub val { "string" } +} +{ + package Num; + sub is_string_amg { 1 } + use overload q(0+) => sub { return $_[0]->val }; + sub val { 12345 }; +} +{ + package NumNoFallback; + sub is_string_amg { undef } + use overload q(0+) => sub { return $_[0]->val }, fallback=>0; + sub val { 1234 }; +} +{ + package NumWithFallback; + sub is_string_amg { 1 } + use overload q(0+)=>sub { return $_[0]->val }, fallback=>1; + sub val { 123456 }; +} +{ + package NoMethod; + use overload q(nomethod)=> sub { $_[0]->val }; + sub is_string_amg { 1 } + sub val { return(ref($_[0])||$_[0]); }; +} +{ + package NoOverload; + sub is_string_amg { 0 } +} + + +{ + # these should be false + + my $string_amg = 0x0a; + my $unary= 8; + + foreach my $class ( + "String", + "Num", + "NumNoFallback", + "NumWithFallback", + "NoMethod", + "NoOverload", + ) { + my $item= bless {}, $class; + my $str= eval { "$item" }; + my $std_str= overload::StrVal($item); + my $ok= does_amagic_apply($item, $string_amg, $unary); + my $want = $class->is_string_amg; + is(0+$ok, $want//0, "amagic_applies($class,string_amg,AMGf_unary) works as expected"); + is($str, $want ? $class->val : defined ($want) ? $std_str : undef, + "Stringified var matches amagic_applies()"); + } +} + done_testing; @@ -3378,44 +3378,149 @@ Perl_try_amagic_un(pTHX_ int method, int flags) { /* -=for apidoc amagic_find +=for apidoc amagic_applies -Check C<sv> for the overloaded (active magic) operation C<method>, and -return the C<CV *> or C<NULL>. +Check C<sv> to see if the overloaded (active magic) operation C<method> +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<method> is one of the values found in F<overload.h>. + 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<flags> are available for future use. +C<method> is an integer enum, one of the values found in F<overload.h>, +for instance C<string_amg>. + +C<flags> 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; @@ -246,15 +246,15 @@ PERL_CALLCONV PADOFFSET Perl_allocmy(pTHX_ const char *const name, const STRLEN #define PERL_ARGS_ASSERT_ALLOCMY \ assert(name) +PERL_CALLCONV bool Perl_amagic_applies(pTHX_ SV *sv, int method, int flags); +#define PERL_ARGS_ASSERT_AMAGIC_APPLIES \ + assert(sv) PERL_CALLCONV SV* Perl_amagic_call(pTHX_ SV* left, SV* right, int method, int dir); #define PERL_ARGS_ASSERT_AMAGIC_CALL \ assert(left); assert(right) 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 |