Optimization: Remove needless list/pushmark pairs from the OP execution

[perl5.git] / lib / overload.t

diff --git a/lib/overload.t b/lib/overload.t
index a132492..c83c0ed 100644 (file)
--- a/lib/overload.t
+++ b/lib/overload.t
@@ -48,7 +48,7 @@ package main;
 
 $| = 1;
 BEGIN { require './test.pl' }
-plan tests => 5184;
+plan tests => 5193;
 
 use Scalar::Util qw(tainted);
 
@@ -202,7 +202,7 @@ is($b, "89");
 is(ref $a, "Oscalar");
 is($copies, 1);
 
-eval q[package Oscalar; use overload ('+=' => sub {$ {$_[0]} += 3*"$_[1]";
+eval q[package Oscalar; use overload ('+=' => sub {$ {$_[0]} += 3*$_[1];
                                                   $_[0] } ) ];
 $c=new Oscalar;                        # Cause rehash
 
@@ -1293,6 +1293,19 @@ foreach my $op (qw(<=> == != < <= > >=)) {
 }
 
 {
+    # Check readonliness of constants, whether shared hash key
+    # scalars or no (brought up in bug #109744)
+    BEGIN { overload::constant integer => sub { "main" }; }
+    eval { ${\5} = 'whatever' };
+    like $@, qr/^Modification of a read-only value attempted at /,
+       'constant overloading makes read-only constants';
+    BEGIN { overload::constant integer => sub { __PACKAGE__ }; }
+    eval { ${\5} = 'whatever' };
+    like $@, qr/^Modification of a read-only value attempted at /,
+       '... even with shared hash key scalars';
+}
+
+{
     package Sklorsh;
     use overload
        bool     => sub { shift->is_cool };
@@ -1873,6 +1886,7 @@ foreach my $op (qw(<=> == != < <= > >=)) {
 
 
        for my $sub (keys %subs) {
+           no warnings 'experimental::smartmatch';
            my $term = $subs{$sub};
            my $t = sprintf $term, '$_[0][0]';
            my $e ="sub { \$funcs .= '($sub)'; my \$r; if (\$use_int) {"
@@ -1914,6 +1928,7 @@ foreach my $op (qw(<=> == != < <= > >=)) {
                                    ? "-\$_[0][0]"
                                    : "$_[3](\$_[0][0])";
                        my $r;
+                       no warnings 'experimental::smartmatch';
                        if ($use_int) {
                            use integer; $r = eval $e;
                        }
@@ -1960,7 +1975,7 @@ foreach my $op (qw(<=> == != < <= > >=)) {
            $use_int = ($int ne '');
            my $plain = $tainted_val;
            my $plain_term = $int . sprintf $sub_term, '$plain';
-           my $exp = eval $plain_term;
+           my $exp = do {no warnings 'experimental::smartmatch'; eval $plain_term };
            diag("eval of plain_term <$plain_term> gave <$@>") if $@;
            is(tainted($exp), $exp_taint,
                        "<$plain_term> taint of expected return");
@@ -1988,7 +2003,7 @@ foreach my $op (qw(<=> == != < <= > >=)) {
 
                    my $res_term  = $int . sprintf $sub_term, $var;
                    my $desc =  "<$res_term> $ov_pkg" ;
-                   my $res = eval $res_term;
+                   my $res = do { no warnings 'experimental::smartmatch'; eval $res_term };
                    diag("eval of res_term $desc gave <$@>") if $@;
                    # uniquely, the inc/dec ops return the original
                    # ref rather than a copy, so stringify it to
@@ -2050,11 +2065,11 @@ fresh_perl_is
     }
 
     package NCmp;
-    use base 'CmpBase';
+    use parent '-norequire', 'CmpBase';
     use overload '<=>' => 'cmp';
 
     package SCmp;
-    use base 'CmpBase';
+    use parent '-norequire', 'CmpBase';
     use overload 'cmp' => 'cmp';
 
     package main;
@@ -2118,7 +2133,7 @@ fresh_perl_is
                 ? $nomethod . "=>'nomethod'," : '';
             eval qq{
                     package NuMB$fall$nomethod;
-                    use base qw/NuMB/;
+                    use parent '-norequire', qw/NuMB/;
                     use overload $nomethod_decl
                     fallback => $fall;
                 };
@@ -2627,6 +2642,65 @@ is eval {"$a"}, overload::StrVal($a), 'fallback is stored under "()"';
     is($obj->val, 7, "correct result (add incr void)");
 }
 
+# [perl #113010]
+{
+    {
+        package OnlyFallback;
+        use overload fallback => 0;
+    }
+    {
+        my $obj = bless {}, 'OnlyFallback';
+        my $died = !eval { "".$obj; 1 };
+        my $err = $@;
+        ok($died, "fallback of 0 causes error");
+        like($err, qr/"\.": no method found/, "correct error");
+    }
+
+    {
+        package OnlyFallbackUndef;
+        use overload fallback => undef;
+    }
+    {
+        my $obj = bless {}, 'OnlyFallbackUndef';
+        my $died = !eval { "".$obj; 1 };
+        my $err = $@;
+        ok($died, "fallback of undef causes error");
+        # this one tries falling back to stringify before dying
+        like($err, qr/"""": no method found/, "correct error");
+    }
+
+    {
+        package OnlyFallbackTrue;
+        use overload fallback => 1;
+    }
+    {
+        my $obj = bless {}, 'OnlyFallbackTrue';
+        my $val;
+        my $died = !eval { $val = "".$obj; 1 };
+        my $err = $@;
+        ok(!$died, "fallback of 1 doesn't cause error")
+            || diag("got error of $err");
+        like($val, qr/^OnlyFallbackTrue=HASH\(/, "stringified correctly");
+    }
+}
+
+{
+    # Making Regexp class overloaded: avoid infinite recursion.
+    # Do this in a separate process since it, well, overloads Regexp!
+    fresh_perl_is(
+       <<'EOF',
+package Regexp;
+use overload q{""} => sub {$_[0] };
+package main;
+my $r1 = qr/1/;
+my $r2 = qr/ABC$r1/;
+print $r2,"\n";
+EOF
+       '(?^:ABC(?^:1))',
+       { stderr => 1 },
+       'overloaded REGEXP'
+    );
+}
 
 { # undefining the overload stash -- KEEP THIS TEST LAST
     package ant;