mktables: Add comment

[perl5.git] / lib / overload.t

diff --git a/lib/overload.t b/lib/overload.t
index afbe999..7efd992 100644 (file)
--- a/lib/overload.t
+++ b/lib/overload.t
@@ -48,7 +48,7 @@ package main;
 
 $| = 1;
 BEGIN { require './test.pl' }
-plan tests => 5191;
+plan tests => 5194;
 
 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;
                 };
@@ -2687,6 +2702,35 @@ EOF
     );
 }
 
+{
+    # RT #121362
+    # splitting the stash HV while rebuilding the overload cache gave
+    # valgrind errors. This test code triggers such a split. It doesn't
+    # actually test anything; its just there for valgrind to spot
+    # problems.
+
+    package A_121362;
+
+    sub stringify { }
+    use overload '""' => 'stringify';
+
+    package B_121362;
+    our @ISA = qw(A_121362);
+
+    package main;
+
+    my $x = bless { }, 'B_121362';
+
+    for ('a'..'z') {
+        delete $B_121362::{stringify}; # delete cache entry
+        no strict 'refs';
+        *{"B_121362::$_"}  = sub { };  # increase size of %B_121362
+        my $y = $x->{value};       # trigger cache add to %B_121362
+    }
+    pass("RT 121362");
+}
+
+
 { # undefining the overload stash -- KEEP THIS TEST LAST
     package ant;
     use overload '+' => 'onion';