This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
propagate context into overloads [perl #47119]
authorJesse Luehrs <doy@tozt.net>
Wed, 27 Jun 2012 02:12:18 +0000 (21:12 -0500)
committerJesse Luehrs <doy@tozt.net>
Thu, 28 Jun 2012 08:06:08 +0000 (03:06 -0500)
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
lib/overload.pm
lib/overload.t
pp.h
pp_hot.c
pp_sys.c

diff --git a/gv.c b/gv.c
index c217bed..c4089cd 100644 (file)
--- 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);
index c1eefc0..deb0b1a 100644 (file)
@@ -1,6 +1,6 @@
 package overload;
 
-our $VERSION = '1.19';
+our $VERSION = '1.20';
 
 %ops = (
     with_assign         => "+ - * / % ** << >> x .",
@@ -496,9 +496,6 @@ If C<E<lt>E<gt>> is overloaded then the same implementation is used
 for both the I<read-filehandle> syntax C<E<lt>$varE<gt>> and
 I<globbing> syntax C<E<lt>${var}E<gt>>.
 
-B<BUGS> Even in list context, the iterator is currently called only
-once and with scalar context.
-
 =item * I<File tests>
 
 The key C<'-X'> is used to specify a subroutine to handle all the
index 03ae2f7..a132492 100644 (file)
@@ -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 (file)
--- a/pp.h
+++ b/pp.h
@@ -397,6 +397,7 @@ Does not use C<TARG>.  See also C<XPUSHu>, C<mPUSHu> and C<PUSHu>.
 #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<TARG>.  See also C<XPUSHu>, C<mPUSHu> and C<PUSHu>.
 /* 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;                   \
index 675f2e5..77b707c 100644 (file)
--- 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--;
index 8ef1df7..fb93732 100644 (file)
--- 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: