Subject: unicode_strings.t: Imprv test output

[perl5.git] / lib / overload.t

diff --git a/lib/overload.t b/lib/overload.t
index 8a632a5..ef65ea5 100644 (file)
--- a/lib/overload.t
+++ b/lib/overload.t
@@ -47,7 +47,8 @@ sub numify { 0 + "${$_[0]}" } # Not needed, additional overhead
 package main;
 
 $| = 1;
-use Test::More tests => 4826;
+BEGIN { require './test.pl' }
+plan tests => 4882;
 
 use Scalar::Util qw(tainted);
 
@@ -1372,11 +1373,11 @@ foreach my $op (qw(<=> == != < <= > >=)) {
     $obj = bless do {my $a; \$a}, 'Shklitza';
     $ref = $obj;
 
-    is ($obj, "CLiK KLAK");
-    is ($ref, "CLiK KLAK");
+    is ("$obj", "CLiK KLAK");
+    is ("$ref", "CLiK KLAK");
 
     weaken $ref;
-    is ($ref, "CLiK KLAK");
+    is ("$ref", "CLiK KLAK");
 
     bless $obj, 'Ksshfwoom';
 
@@ -1722,38 +1723,24 @@ foreach my $op (qw(<=> == != < <= > >=)) {
            #   SCALAR FETCH: initial, sub=,  sub+=, eval-return,
            #          STORE: copy, mutator
            # for fallback, we just stringify, so eval-return and copy skipped
-           #
-           # XXX TODO concat LH overload with fallback calls "" and FETCH
-           # too often
-           if ($_ eq '.') {
-               push @tests, [ 18, $e, "(=)($_=)", '("")("")',
-                       [ 3, 4, 2,     2, 4, 1 ], 1 ];
-           }
-           else {
-               push @tests, [ 18, $e, "(=)($_=)", '("")',
-                       [ 3, 4, 2,     2, 3, 1 ], 1 ];
-           }
+
+           push @tests, [ 18, $e, "(=)($_=)", '("")',
+                           [ 3, 4, 2,     2, 3, 1 ], 1 ];
 
            $subs{$_} =
                "do { my \$arg = %s; \$_[2] ? (3 $op \$arg) : (\$arg $op 3) }";
            # ARRAY  FETCH: initial
            # SCALAR FETCH: initial eval-return,
-           # with fallback, we just stringify, so eval-return skipped
-
-           # XXX TODO concat overload with fallback calls FETCH too often
-           if ($_ eq '.') {
-               push @tests, [ 18, "%s $op 3", "($_)", '("")',
-                               [ 1, 2, 0,     1, 2, 0 ], 1 ];
-               push @tests, [ 18, "3 $op %s", "($_)", '("")',
-                               [ 1, 2, 0,     1, 2, 0 ], 1 ];
-           }
-           else {
-               push @tests, [ 18, "%s $op 3", "($_)", '("")',
-                               [ 1, 2, 0,     1, 1, 0 ], 1 ];
-               next if $_ eq 'x'; # repeat only overloads on LHS
-               push @tests, [ 18, "3 $op %s", "($_)", '("")',
-                               [ 1, 2, 0,     1, 1, 0 ], 1 ];
-           }
+           # with fallback, we just stringify, so eval-return skipped,
+           #    but an extra FETCH happens in sub"", except for 'x',
+           #    which passes a copy of the RV to sub"", avoiding the
+           #    second FETCH
+
+           push @tests, [ 18, "%s $op 3", "($_)", '("")',
+                           [ 1, 2, 0,     1, ($_ eq '.' ? 2 : 1), 0 ], 1 ];
+           next if $_ eq 'x'; # repeat only overloads on LHS
+           push @tests, [ 18, "3 $op %s", "($_)", '("")',
+                           [ 1, 2, 0,     1, 2, 0 ], 1 ];
        }
 
        for (qw(++ --)) {
@@ -1812,10 +1799,7 @@ foreach my $op (qw(<=> == != < <= > >=)) {
 
        # note: this is testing unary qr, not binary =~
        $subs{qr} = '(qr/%s/)';
-       # XXX TODO qr overload with fallback calls "" and FETCH too often
-       #push @tests, [ "abc", '"abc" =~ (%s)', '(qr)', '("")', [ 1, 2, 0 ], 0 ];
-       push @tests, [ "abc", '"abc" =~ (%s)', '(qr)', '("")("")',
-                           [ 1, 2, 0,  1, 5, 0 ], 0 ];
+       push @tests, [ "abc", '"abc" =~ (%s)', '(qr)', '("")', [ 1, 2, 0 ], 0 ];
 
        $e = '"abc" ~~ (%s)';
        $subs{'~~'} = $e;
@@ -1832,17 +1816,7 @@ foreach my $op (qw(<=> == != < <= > >=)) {
        # long as the tied and untied versions return the same value.
        # The flags below are chosen to test all uses of tryAMAGICftest_MG
        for (qw(r e f l t T)) {
-           # XXX TODO -X overload with fallback calls FETCH too often
-           # XXX and -t calls "" too often too
-           #push @tests, [ 'TEST', "-$_ (%s)", '(-X)', '("")', [ 1, 2, 0 ], 0 ];
-           if ($_ eq 't') {
-               push @tests, [ 'TEST', "-$_ (%s)", '(-X)', '("")("")',
-                                   [ 1, 2, 0,    1, 5, 0 ], 0 ];
-           }
-           else {
-               push @tests, [ 'TEST', "-$_ (%s)", '(-X)', '("")',
-                                   [ 1, 2, 0,    1, 3, 0 ], 0 ];
-           }
+           push @tests, [ 'TEST', "-$_ (%s)", '(-X)', '("")', [ 1, 2, 0 ], 0 ];
        }
 
        $subs{'${}'} = '%s';
@@ -1867,6 +1841,11 @@ foreach my $op (qw(<=> == != < <= > >=)) {
 
        # XXX TODO: '<>'
 
+       # eval should do tie, overload on its arg before checking taint */
+       push @tests, [ '1;', 'eval q(eval %s); $@ =~ /Insecure/',
+               '("")', '("")', [ 1, 2, 0 ], 0 ];
+
+
        for my $sub (keys %subs) {
            my $term = $subs{$sub};
            my $t = sprintf $term, '$_[0][0]';
@@ -1990,7 +1969,6 @@ foreach my $op (qw(<=> == != < <= > >=)) {
                    $res = "$res" if $res_term =~ /\+\+|--/;
                    is(tainted($res), $exp_taint,
                            "$desc taint of result return");
-                   #XXX$res = "$res";
                    is($res, $exp, "$desc return value");
                    my $fns =($ov_pkg eq 'RT57012_OV_FB')
                                ? $exp_fb_funcs : $exp_funcs;
@@ -2013,4 +1991,20 @@ foreach my $op (qw(<=> == != < <= > >=)) {
     }
 }
 
+# Test overload from the main package
+fresh_perl_is
+ '$^W = 1; use overload q\""\ => sub {"ning"}; print bless []',
+ 'ning',
+  { switches => ['-wl'], stderr => 1 },
+ 'use overload from the main package'
+;
+
+{
+    package blessed_methods;
+    use overload '+' => sub {};
+    bless overload::Method __PACKAGE__,'+';
+    eval { overload::Method __PACKAGE__,'+' };
+    ::is($@, '', 'overload::Method and blessed overload methods');
+}
+
 # EOF