diff options
| -rw-r--r-- | gv.c | 11 | ||||
| -rw-r--r-- | lib/overload.t | 38 | ||||
| -rw-r--r-- | pp.c | 6 | ||||
| -rw-r--r-- | pp.h | 1 |
4 files changed, 48 insertions, 8 deletions
@@ -2842,7 +2842,9 @@ Perl_try_amagic_un(pTHX_ int method, int flags) { SvGETMAGIC(arg); if (SvAMAGIC(arg) && (tmpsv = amagic_call(arg, &PL_sv_undef, method, - AMGf_noright | AMGf_unary))) { + AMGf_noright | AMGf_unary + | (flags & AMGf_numarg)))) + { if (flags & AMGf_set) { SETs(tmpsv); } @@ -2887,7 +2889,8 @@ Perl_try_amagic_bin(pTHX_ int method, int flags) { if (SvAMAGIC(left) || SvAMAGIC(right)) { SV * const tmpsv = amagic_call(left, right, method, - ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0)); + ((flags & AMGf_assign) && opASSIGN ? AMGf_assign: 0) + | (flags & AMGf_numarg)); if (tmpsv) { if (flags & AMGf_set) { (void)POPs; @@ -3395,6 +3398,10 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) PUSHs(newSVpvn_flags(AMG_id2name(method + assignshift), AMG_id2namelen(method + assignshift), SVs_TEMP)); } + else if (flags & AMGf_numarg) + PUSHs(&PL_sv_undef); + if (flags & AMGf_numarg) + PUSHs(&PL_sv_yes); PUSHs(MUTABLE_SV(cv)); PUTBACK; oldmark = TOPMARK; diff --git a/lib/overload.t b/lib/overload.t index 9e9798c59d..6bbbb0b9d3 100644 --- a/lib/overload.t +++ b/lib/overload.t @@ -48,7 +48,7 @@ package main; $| = 1; BEGIN { require './test.pl' } -plan tests => 5200; +plan tests => 5215; use Scalar::Util qw(tainted); @@ -2759,7 +2759,11 @@ package bitops { use overload do { my %o; for my $o (qw(& | ^ ~ &. |. ^. ~. &= |= ^= &.= |.= ^.=)) { - $o{$o} = sub { push @o, $o; $_[0] } + $o{$o} = sub { + ::ok !defined $_[3], "undef (or nonexistent) arg 3 for $o"; + push @o, $o, scalar @_, $_[4]//'u'; + $_[0] + } } %o, '=' => sub { bless [] }; } @@ -2781,9 +2785,37 @@ package bitops { $o &.= 0; $o |.= 0; $o ^.= 0; - is "@bitops::o", '& | ^ ~ &. |. ^. ~. &= |= ^= &.= |.= ^.=', + # elems are in triplets: op, length of @_, numeric? (1/u for y/n) + is "@bitops::o", '& 5 1 | 5 1 ^ 5 1 ~ 5 1 &. 3 u |. 3 u ^. 3 u ~. 3 u ' . '&= 5 1 |= 5 1 ^= 5 1 &.= 3 u |.= 3 u ^.= 3 u', 'experimental "bitwise" ops' } +package bitops2 { + our @o; + use overload + nomethod => sub { push @o, $_[3], scalar @_, $_[4]//'u'; $_[0] }, + '=' => sub { bless [] }; +} +{ + use experimental 'bitwise'; + my $o = bless [], bitops2::; + $_ = $o & 0; + $_ = $o | 0; + $_ = $o ^ 0; + $_ = ~$o; + $_ = $o &. 0; + $_ = $o |. 0; + $_ = $o ^. 0; + $_ = ~.$o; + $o &= 0; + $o |= 0; + $o ^= 0; + $o &.= 0; + $o |.= 0; + $o ^.= 0; + # elems are in triplets: op, length of @_, numeric? (1/u for y/n) + is "@bitops2::o", '& 5 1 | 5 1 ^ 5 1 ~ 5 1 &. 4 u |. 4 u ^. 4 u ~. 4 u ' . '&= 5 1 |= 5 1 ^= 5 1 &.= 4 u |.= 4 u ^.= 4 u', + 'experimental "bitwise" ops with nomethod' +} { # undefining the overload stash -- KEEP THIS TEST LAST package ant; @@ -2227,7 +2227,7 @@ PP(pp_bit_and) PP(pp_nbit_and) { dSP; - tryAMAGICbin_MG(band_amg, AMGf_assign); + tryAMAGICbin_MG(band_amg, AMGf_assign|AMGf_numarg); { dATARGET; dPOPTOPssrl; if (PL_op->op_private & HINT_INTEGER) { @@ -2297,7 +2297,7 @@ PP(pp_nbit_or) const int op_type = PL_op->op_type; tryAMAGICbin_MG((op_type == OP_NBIT_OR ? bor_amg : bxor_amg), - AMGf_assign); + AMGf_assign|AMGf_numarg); { dATARGET; dPOPTOPssrl; if (PL_op->op_private & HINT_INTEGER) { @@ -2515,7 +2515,7 @@ PP(pp_complement) PP(pp_ncomplement) { dSP; - tryAMAGICun_MG(compl_amg, AMGf_numeric); + tryAMAGICun_MG(compl_amg, AMGf_numeric|AMGf_numarg); { dTARGET; dTOPss; if (PL_op->op_private & HINT_INTEGER) { @@ -405,6 +405,7 @@ Does not use C<TARG>. See also C<XPUSHu>, C<mPUSHu> and C<PUSHu>. #define AMGf_numeric 0x10 /* for Perl_try_amagic_bin */ #define AMGf_set 0x20 /* for Perl_try_amagic_bin */ #define AMGf_want_list 0x40 +#define AMGf_numarg 0x80 /* do SvGETMAGIC on the stack args before checking for overload */ |