From 67288365cab33e76a48b697c001c11d4dc5b1912 Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Tue, 26 Jun 2012 21:12:18 -0500 Subject: [PATCH] propagate context into overloads [perl #47119] amagic_call now does its best to propagate the operator's context into the overload callback. It's not always possible - for instance, dereferencing and stringify/boolify/numify always have to return a value, even if it's not used, due to the way the overload callback works in those cases - but the majority of cases should now work. In particular, overloading <> to handle list context properly is now possible. For backcompat reasons (amagic_call and friends are technically public api functions), list context will not be propagated unless specifically requested via the AMGf_want_list flag. If this is passed, and the operator is called in list context, amagic_call returns an AV* holding all of the returned values instead of an SV*. Void context always results in amagic_call returning &PL_sv_undef. --- gv.c | 104 ++++++++++++++++++++++- lib/overload.pm | 5 +- lib/overload.t | 260 +++++++++++++++++++++++++++++++++++++++++++++++++++++++- pp.h | 35 ++++++-- pp_hot.c | 2 +- pp_sys.c | 2 +- 6 files changed, 392 insertions(+), 16 deletions(-) diff --git a/gv.c b/gv.c index c217bed..c4089cd 100644 --- a/gv.c +++ b/gv.c @@ -2590,6 +2590,7 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) int assign = AMGf_assign & flags; const int assignshift = assign ? 1 : 0; int use_default_op = 0; + int force_scalar = 0; #ifdef DEBUGGING int fl=0; #endif @@ -2836,6 +2837,64 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) force_cpy = force_cpy || assign; } } + + switch (method) { + /* in these cases, we're calling '+' or '-' as a fallback for a ++ or -- + * operation. we need this to return a value, so that it can be assigned + * later on, in the postpr block (case inc_amg/dec_amg), even if the + * increment or decrement was itself called in void context */ + case inc_amg: + if (off == add_amg) + force_scalar = 1; + break; + case dec_amg: + if (off == subtr_amg) + force_scalar = 1; + break; + /* in these cases, we're calling an assignment variant of an operator + * (+= rather than +, for instance). regardless of whether it's a + * fallback or not, it always has to return a value, which will be + * assigned to the proper variable later */ + case add_amg: + case subtr_amg: + case mult_amg: + case div_amg: + case modulo_amg: + case pow_amg: + case lshift_amg: + case rshift_amg: + case repeat_amg: + case concat_amg: + case band_amg: + case bor_amg: + case bxor_amg: + if (assign) + force_scalar = 1; + break; + /* the copy constructor always needs to return a value */ + case copy_amg: + force_scalar = 1; + break; + /* because of the way these are implemented (they don't perform the + * dereferencing themselves, they return a reference that perl then + * dereferences later), they always have to be in scalar context */ + case to_sv_amg: + case to_av_amg: + case to_hv_amg: + case to_gv_amg: + case to_cv_amg: + force_scalar = 1; + break; + /* these don't have an op of their own; they're triggered by their parent + * op, so the context there isn't meaningful ('$a and foo()' in void + * context still needs to pass scalar context on to $a's bool overload) */ + case bool__amg: + case numer_amg: + case string_amg: + force_scalar = 1; + break; + } + #ifdef DEBUGGING if (!notfound) { DEBUG_o(Perl_deb(aTHX_ @@ -2895,12 +2954,29 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) BINOP myop; SV* res; const bool oldcatch = CATCH_GET; + I32 oldmark, nret; + int gimme = force_scalar ? G_SCALAR : GIMME_V; CATCH_SET(TRUE); Zero(&myop, 1, BINOP); myop.op_last = (OP *) &myop; myop.op_next = NULL; - myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED; + myop.op_flags = OPf_STACKED; + + switch (gimme) { + case G_VOID: + myop.op_flags |= OPf_WANT_VOID; + break; + case G_ARRAY: + if (flags & AMGf_want_list) { + myop.op_flags |= OPf_WANT_LIST; + break; + } + /* FALLTHROUGH */ + default: + myop.op_flags |= OPf_WANT_SCALAR; + break; + } PUSHSTACKi(PERLSI_OVERLOAD); ENTER; @@ -2921,13 +2997,37 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags) } PUSHs(MUTABLE_SV(cv)); PUTBACK; + oldmark = TOPMARK; if ((PL_op = PL_ppaddr[OP_ENTERSUB](aTHX))) CALLRUNOPS(aTHX); LEAVE; SPAGAIN; + nret = SP - (PL_stack_base + oldmark); + + switch (gimme) { + case G_VOID: + /* returning NULL has another meaning, and we check the context + * at the call site too, so this can be differentiated from the + * scalar case */ + res = &PL_sv_undef; + SP = PL_stack_base + oldmark; + break; + case G_ARRAY: { + if (flags & AMGf_want_list) { + res = sv_2mortal((SV *)newAV()); + av_extend((AV *)res, nret); + while (nret--) + av_store((AV *)res, nret, POPs); + break; + } + /* FALLTHROUGH */ + } + default: + res = POPs; + break; + } - res=POPs; PUTBACK; POPSTACK; CATCH_SET(oldcatch); diff --git a/lib/overload.pm b/lib/overload.pm index c1eefc0..deb0b1a 100644 --- a/lib/overload.pm +++ b/lib/overload.pm @@ -1,6 +1,6 @@ package overload; -our $VERSION = '1.19'; +our $VERSION = '1.20'; %ops = ( with_assign => "+ - * / % ** << >> x .", @@ -496,9 +496,6 @@ If CE> is overloaded then the same implementation is used for both the I syntax C$varE> and I syntax C${var}E>. -B Even in list context, the iterator is currently called only -once and with scalar context. - =item * I The key C<'-X'> is used to specify a subroutine to handle all the diff --git a/lib/overload.t b/lib/overload.t index 03ae2f7..a132492 100644 --- a/lib/overload.t +++ b/lib/overload.t @@ -48,7 +48,7 @@ package main; $| = 1; BEGIN { require './test.pl' } -plan tests => 5100; +plan tests => 5184; use Scalar::Util qw(tainted); @@ -2369,6 +2369,264 @@ is eval { !$a }, 1, "' in method name" or diag $@; $a = bless [],'dodo'; is eval {"$a"}, overload::StrVal($a), 'fallback is stored under "()"'; +# [perl #47119] +{ + my $context; + + { + package Splitter; + use overload '<>' => \&chars; + + sub new { + my $class = shift; + my ($string) = @_; + bless \$string, $class; + } + + sub chars { + my $self = shift; + my @chars = split //, $$self; + $context = wantarray; + return @chars; + } + } + + my $obj = Splitter->new('bar'); + + $context = 42; # not 1, '', or undef + + my @foo = <$obj>; + is($context, 1, "list context (readline list)"); + is(scalar(@foo), 3, "correct result (readline list)"); + is($foo[0], 'b', "correct result (readline list)"); + is($foo[1], 'a', "correct result (readline list)"); + is($foo[2], 'r', "correct result (readline list)"); + + $context = 42; + + my $foo = <$obj>; + ok(defined($context), "scalar context (readline scalar)"); + is($context, '', "scalar context (readline scalar)"); + is($foo, 3, "correct result (readline scalar)"); + + $context = 42; + + <$obj>; + ok(!defined($context), "void context (readline void)"); + + $context = 42; + + my @bar = <${obj}>; + is($context, 1, "list context (glob list)"); + is(scalar(@bar), 3, "correct result (glob list)"); + is($bar[0], 'b', "correct result (glob list)"); + is($bar[1], 'a', "correct result (glob list)"); + is($bar[2], 'r', "correct result (glob list)"); + + $context = 42; + + my $bar = <${obj}>; + ok(defined($context), "scalar context (glob scalar)"); + is($context, '', "scalar context (glob scalar)"); + is($bar, 3, "correct result (glob scalar)"); + + $context = 42; + + <${obj}>; + ok(!defined($context), "void context (glob void)"); +} +{ + my $context; + + { + package StringWithContext; + use overload '""' => \&stringify; + + sub new { + my $class = shift; + my ($string) = @_; + bless \$string, $class; + } + + sub stringify { + my $self = shift; + $context = wantarray; + return $$self; + } + } + + my $obj = StringWithContext->new('bar'); + + $context = 42; + + my @foo = "".$obj; + ok(defined($context), "scalar context (stringify list)"); + is($context, '', "scalar context (stringify list)"); + is(scalar(@foo), 1, "correct result (stringify list)"); + is($foo[0], 'bar', "correct result (stringify list)"); + + $context = 42; + + my $foo = "".$obj; + ok(defined($context), "scalar context (stringify scalar)"); + is($context, '', "scalar context (stringify scalar)"); + is($foo, 'bar', "correct result (stringify scalar)"); + + $context = 42; + + "".$obj; + + is($context, '', "scalar context (stringify void)"); +} +{ + my ($context, $swap); + + { + package AddWithContext; + use overload '+' => \&add; + + sub new { + my $class = shift; + my ($num) = @_; + bless \$num, $class; + } + + sub add { + my $self = shift; + my ($other, $swapped) = @_; + $context = wantarray; + $swap = $swapped; + return ref($self)->new($$self + $other); + } + + sub val { ${ $_[0] } } + } + + my $obj = AddWithContext->new(6); + + $context = $swap = 42; + + my @foo = $obj + 7; + ok(defined($context), "scalar context (add list)"); + is($context, '', "scalar context (add list)"); + ok(defined($swap), "not swapped (add list)"); + is($swap, '', "not swapped (add list)"); + is(scalar(@foo), 1, "correct result (add list)"); + is($foo[0]->val, 13, "correct result (add list)"); + + $context = $swap = 42; + + @foo = 7 + $obj; + ok(defined($context), "scalar context (add list swap)"); + is($context, '', "scalar context (add list swap)"); + ok(defined($swap), "swapped (add list swap)"); + is($swap, 1, "swapped (add list swap)"); + is(scalar(@foo), 1, "correct result (add list swap)"); + is($foo[0]->val, 13, "correct result (add list swap)"); + + $context = $swap = 42; + + my $foo = $obj + 7; + ok(defined($context), "scalar context (add scalar)"); + is($context, '', "scalar context (add scalar)"); + ok(defined($swap), "not swapped (add scalar)"); + is($swap, '', "not swapped (add scalar)"); + is($foo->val, 13, "correct result (add scalar)"); + + $context = $swap = 42; + + my $foo = 7 + $obj; + ok(defined($context), "scalar context (add scalar swap)"); + is($context, '', "scalar context (add scalar swap)"); + ok(defined($swap), "swapped (add scalar swap)"); + is($swap, 1, "swapped (add scalar swap)"); + is($foo->val, 13, "correct result (add scalar swap)"); + + $context = $swap = 42; + + $obj + 7; + + ok(!defined($context), "void context (add void)"); + ok(defined($swap), "not swapped (add void)"); + is($swap, '', "not swapped (add void)"); + + $context = $swap = 42; + + 7 + $obj; + + ok(!defined($context), "void context (add void swap)"); + ok(defined($swap), "swapped (add void swap)"); + is($swap, 1, "swapped (add void swap)"); + + $obj = AddWithContext->new(6); + + $context = $swap = 42; + + my @foo = $obj += 7; + ok(defined($context), "scalar context (add assign list)"); + is($context, '', "scalar context (add assign list)"); + ok(!defined($swap), "not swapped and autogenerated (add assign list)"); + is(scalar(@foo), 1, "correct result (add assign list)"); + is($foo[0]->val, 13, "correct result (add assign list)"); + is($obj->val, 13, "correct result (add assign list)"); + + $obj = AddWithContext->new(6); + + $context = $swap = 42; + + my $foo = $obj += 7; + ok(defined($context), "scalar context (add assign scalar)"); + is($context, '', "scalar context (add assign scalar)"); + ok(!defined($swap), "not swapped and autogenerated (add assign scalar)"); + is($foo->val, 13, "correct result (add assign scalar)"); + is($obj->val, 13, "correct result (add assign scalar)"); + + $obj = AddWithContext->new(6); + + $context = $swap = 42; + + $obj += 7; + + ok(defined($context), "scalar context (add assign void)"); + is($context, '', "scalar context (add assign void)"); + ok(!defined($swap), "not swapped and autogenerated (add assign void)"); + is($obj->val, 13, "correct result (add assign void)"); + + $obj = AddWithContext->new(6); + + $context = $swap = 42; + + my @foo = ++$obj; + ok(defined($context), "scalar context (add incr list)"); + is($context, '', "scalar context (add incr list)"); + ok(!defined($swap), "not swapped and autogenerated (add incr list)"); + is(scalar(@foo), 1, "correct result (add incr list)"); + is($foo[0]->val, 7, "correct result (add incr list)"); + is($obj->val, 7, "correct result (add incr list)"); + + $obj = AddWithContext->new(6); + + $context = $swap = 42; + + my $foo = ++$obj; + ok(defined($context), "scalar context (add incr scalar)"); + is($context, '', "scalar context (add incr scalar)"); + ok(!defined($swap), "not swapped and autogenerated (add incr scalar)"); + is($foo->val, 7, "correct result (add incr scalar)"); + is($obj->val, 7, "correct result (add incr scalar)"); + + $obj = AddWithContext->new(6); + + $context = $swap = 42; + + ++$obj; + + ok(defined($context), "scalar context (add incr void)"); + is($context, '', "scalar context (add incr void)"); + ok(!defined($swap), "not swapped and autogenerated (add incr void)"); + is($obj->val, 7, "correct result (add incr void)"); +} + { # undefining the overload stash -- KEEP THIS TEST LAST package ant; diff --git a/pp.h b/pp.h index 93aeb91..4661f42 100644 --- a/pp.h +++ b/pp.h @@ -397,6 +397,7 @@ Does not use C. See also C, C and C. #define AMGf_unary 8 #define AMGf_numeric 0x10 /* for Perl_try_amagic_bin */ #define AMGf_set 0x20 /* for Perl_try_amagic_bin */ +#define AMGf_want_list 0x40 /* do SvGETMAGIC on the stack args before checking for overload */ @@ -418,21 +419,41 @@ Does not use C. See also C, C and C. /* No longer used in core. Use AMG_CALLunary instead */ #define AMG_CALLun(sv,meth) AMG_CALLunary(sv, CAT2(meth,_amg)) -#define tryAMAGICunTARGET(meth, shift, jump) \ +#define tryAMAGICunTARGET(meth, shift, jump) \ + tryAMAGICunTARGET_flags(meth, shift, jump, 0) +#define tryAMAGICunTARGETlist(meth, shift, jump) \ + tryAMAGICunTARGET_flags(meth, shift, jump, AMGf_want_list) +#define tryAMAGICunTARGET_flags(meth, shift, jump, flags) \ STMT_START { \ - dATARGET; \ dSP; \ SV *tmpsv; \ SV *arg= sp[shift]; \ + int gimme = GIMME_V; \ if (SvAMAGIC(arg) && \ (tmpsv = amagic_call(arg, &PL_sv_undef, meth, \ - AMGf_noright | AMGf_unary))) { \ + flags | AMGf_noright | AMGf_unary))) { \ SPAGAIN; \ sp += shift; \ - sv_setsv(TARG, tmpsv); \ - if (opASSIGN) \ - sp--; \ - SETTARG; \ + if (gimme == G_VOID) { \ + (void)POPs; /* XXX ??? */ \ + } \ + else if ((flags & AMGf_want_list) && gimme == G_ARRAY) { \ + int i; \ + I32 len; \ + assert(SvTYPE(tmpsv) == SVt_PVAV); \ + len = av_len((AV *)tmpsv) + 1; \ + (void)POPs; /* get rid of the arg */ \ + EXTEND(sp, len); \ + for (i = 0; i < len; ++i) \ + PUSHs(av_shift((AV *)tmpsv)); \ + } \ + else { /* AMGf_want_scalar */ \ + dATARGET; /* just use the arg's location */ \ + sv_setsv(TARG, tmpsv); \ + if (opASSIGN) \ + sp--; \ + SETTARG; \ + } \ PUTBACK; \ if (jump) { \ OP *jump_o = NORMAL->op_next; \ diff --git a/pp_hot.c b/pp_hot.c index 675f2e5..77b707c 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -329,7 +329,7 @@ PP(pp_readline) dSP; if (TOPs) { SvGETMAGIC(TOPs); - tryAMAGICunTARGET(iter_amg, 0, 0); + tryAMAGICunTARGETlist(iter_amg, 0, 0); PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); } else PL_last_in_gv = PL_argvgv, PL_stack_sp--; diff --git a/pp_sys.c b/pp_sys.c index 8ef1df7..fb93732 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -363,7 +363,7 @@ PP(pp_glob) * is called once and only once */ if (SvGMAGICAL(TOPm1s)) TOPm1s = sv_2mortal(newSVsv(TOPm1s)); - tryAMAGICunTARGET(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL)); + tryAMAGICunTARGETlist(iter_amg, -1, (PL_op->op_flags & OPf_SPECIAL)); if (PL_op->op_flags & OPf_SPECIAL) { /* call Perl-level glob function instead. Stack args are: -- 1.8.3.1