diff options
| -rw-r--r-- | lib/overload.t | 21 | ||||
| -rw-r--r-- | op.c | 1 | ||||
| -rw-r--r-- | pp.h | 9 | ||||
| -rw-r--r-- | pp_hot.c | 2 | ||||
| -rw-r--r-- | pp_sys.c | 7 |
5 files changed, 25 insertions, 15 deletions
diff --git a/lib/overload.t b/lib/overload.t index 20d3e21b95..df91544cf2 100644 --- a/lib/overload.t +++ b/lib/overload.t @@ -48,7 +48,7 @@ package main; $| = 1; BEGIN { require './test.pl' } -plan tests => 4942; +plan tests => 4980; use Scalar::Util qw(tainted); @@ -707,13 +707,7 @@ is($c, "bareword"); sub iter { my ($x) = @_; return undef if $$x < 0; return $$x--; } } -# XXX iterator overload not intended to work with CORE::GLOBAL? -if (defined &CORE::GLOBAL::glob) { - is('1', '1'); - is('1', '1'); - is('1', '1'); -} -else { +{ my $iter = iterator->new(5); my $acc = ''; my $out; @@ -1839,7 +1833,11 @@ foreach my $op (qw(<=> == != < <= > >=)) { push @tests, [ \*RT57012A, '*RT57012B = *{%s}; our $RT57012B', '(*{})', undef, [ 1, 1, 0 ], 0 ]; - # XXX TODO: '<>' + my $iter_text = ("some random text\n" x 100) . $^X; + open my $iter_fh, '<', \$iter_text + or die "open of \$iter_text gave ($!)\n"; + $subs{'<>'} = '<$iter_fh>'; + push @tests, [ $iter_fh, '<%s>', '(<>)', undef, [ 1, 1, 0 ], 1 ]; # eval should do tie, overload on its arg before checking taint */ push @tests, [ '1;', 'eval q(eval %s); $@ =~ /Insecure/', @@ -1940,7 +1938,6 @@ foreach my $op (qw(<=> == != < <= > >=)) { "<$plain_term> taint of expected return"); for my $ov_pkg (qw(RT57012_OV RT57012_OV_FB)) { - # the deref ops don't support fallback next if $ov_pkg eq 'RT57012_OV_FB' and not defined $exp_fb_funcs; my ($exp_fetch_a, $exp_fetch_s, $exp_store) = @@ -1953,7 +1950,9 @@ foreach my $op (qw(<=> == != < <= > >=)) { $ta[0] = bless [ $tainted_val ], $ov_pkg; my $oload = bless [ $tainted_val ], $ov_pkg; - for my $var ('$ta[0]', '$ts', '$oload') { + for my $var ('$ta[0]', '$ts', '$oload', + ($sub_term eq '<%s>' ? '${ts}' : ()) + ) { $funcs = ''; $fetches = 0; @@ -7678,6 +7678,7 @@ Perl_ck_glob(pTHX_ OP *o) * \ null - const(wildcard) - const(ix) */ o->op_flags |= OPf_SPECIAL; + o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP); op_append_elem(OP_GLOB, o, newSVOP(OP_CONST, 0, newSViv(PL_glob_index++))); o = newLISTOP(OP_LIST, 0, o, NULL); @@ -431,7 +431,7 @@ 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) \ +#define tryAMAGICunTARGET(meth, shift, jump) \ STMT_START { \ dSP; \ sp--; /* get TARGET from below PL_stack_sp */ \ @@ -449,7 +449,12 @@ Does not use C<TARG>. See also C<XPUSHu>, C<mPUSHu> and C<PUSHu>. if (opASSIGN) \ sp--; \ SETTARG; \ - RETURN; \ + PUTBACK; \ + if (jump) { \ + PL_markstack_ptr--; \ + return NORMAL->op_next->op_next; \ + } \ + return NORMAL; \ } \ } \ } STMT_END @@ -315,7 +315,7 @@ PP(pp_readline) { dVAR; dSP; SvGETMAGIC(TOPs); - tryAMAGICunTARGET(iter_amg, 0); + tryAMAGICunTARGET(iter_amg, 0, 0); PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--); if (!isGV_with_GP(PL_last_in_gv)) { if (SvROK(PL_last_in_gv) && isGV_with_GP(SvRV(PL_last_in_gv))) @@ -358,6 +358,12 @@ PP(pp_glob) { dVAR; OP *result; + dSP; + /* make a copy of the pattern, to ensure that magic is called once + * and only once */ + TOPm1s = sv_2mortal(newSVsv(TOPm1s)); + + tryAMAGICunTARGET(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: @@ -368,7 +374,6 @@ PP(pp_glob) } /* stack args are: wildcard, gv(_GEN_n) */ - tryAMAGICunTARGET(iter_amg, -1); /* Note that we only ever get here if File::Glob fails to load * without at the same time croaking, for some reason, or if |