Front page | perl.perl5.changes |
Postings from June 2012
[perl.git] branch blead, updated. v5.17.1-210-g6728836
From:
Jesse Luehrs
Date:
June 28, 2012 01:07
Subject:
[perl.git] branch blead, updated. v5.17.1-210-g6728836
Message ID:
E1Sk9l8-0004vo-5p@camel.ams6.corp.booking.com
In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/67288365cab33e76a48b697c001c11d4dc5b1912?hp=591097e07a9ddfd1783a99ea394ab7e4113242b3>
- Log -----------------------------------------------------------------
commit 67288365cab33e76a48b697c001c11d4dc5b1912
Author: Jesse Luehrs <doy@tozt.net>
Date: Tue Jun 26 21:12:18 2012 -0500
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.
-----------------------------------------------------------------------
Summary of changes:
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 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
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<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; \
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:
--
Perl5 Master Repository
-
[perl.git] branch blead, updated. v5.17.1-210-g6728836
by Jesse Luehrs