make <expr> always overload if expr is overloaded

Due to the way that '<> as glob' was parsed differently from
'<> as filehandle' from 5.6 onwards, something like <$foo[0]>
didn't handle overloading, even where $foo[0] was an overloaded object.
This was contrary to the docs for overload, and meant that <> couldn't
be used as a general overloaded iterator operator.

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;
diff --git a/op.c b/op.c
index a1b11a2d97..f7c8d71f95 100644
--- a/op.c
+++ b/op.c
@@ -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);
diff --git a/pp.h b/pp.h
index 5ba9ae2109..4d0395314a 100644
--- a/pp.h
+++ b/pp.h
@@ -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
diff --git a/pp_hot.c b/pp_hot.c
index 5c665366c4..67e2d804b7 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -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)))
diff --git a/pp_sys.c b/pp_sys.c
index 7144bc3725..a657d3632f 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -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