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.

diff --git a/lib/overload.t b/lib/overload.t
index 20d3e21..df91544 100644 (file)
--- 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 a1b11a2..f7c8d71 100644 (file)
--- 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 5ba9ae2..4d03953 100644 (file)
--- 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 5c66536..67e2d80 100644 (file)
--- 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 7144bc3..a657d36 100644 (file)
--- 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