mktables: Convert to BELL meaning U+1F514

[perl5.git] / lib / overload.t

diff --git a/lib/overload.t b/lib/overload.t
index 9637893..87845b1 100644 (file)
--- a/lib/overload.t
+++ b/lib/overload.t
@@ -48,7 +48,7 @@ package main;
 
 $| = 1;
 BEGIN { require './test.pl' }
-plan tests => 5046;
+plan tests => 5082;
 
 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
 
@@ -267,7 +267,7 @@ is("$aI", "xx");
 is($aI, "xx");
 is("b${aI}c", "_._.b.__.xx._.__.c._");
 
-# Here we test that both "no overloading" and
+# Here we test that both "no overload" and
 # blessing to a package update hash
 
 eval "package Oscalar; no overload '.'";
@@ -962,11 +962,16 @@ unless ($aaa) {
     my $a = "" ;
     local $SIG{__WARN__} = sub {$a = $_[0]} ;
     $x = eval ' use overload "~|_|~" => sub{} ' ;
+    eval ' no overload "~|_|~" ' ;
     is($a, "");
     use warnings 'overload' ;
     $x = eval ' use overload "~|_|~" => sub{} ' ;
     like($a, qr/^overload arg '~\|_\|~' is invalid at \(eval \d+\) line /,
        'invalid arg warning');
+    undef $a;
+    eval ' no overload "~|_|~" ' ;
+    like($a, qr/^overload arg '~\|_\|~' is invalid at \(eval \d+\) line /,
+       'invalid arg warning');
 }
 
 {
@@ -1114,18 +1119,6 @@ like ($@, qr/zap/);
 }
 
 {
-    package Numify;
-    use overload (qw(0+ numify fallback 1));
-
-    sub new {
-       my $val = $_[1];
-       bless \$val, $_[0];
-    }
-
-    sub numify { ${$_[0]} }
-}
-
-{
     package perl31793;
     use overload cmp => sub { 0 };
     package perl31793_fb;
@@ -1146,8 +1139,20 @@ like ($@, qr/zap/);
     like(overload::StrVal($no),       qr/^no_overload=ARRAY\(0x[0-9a-f]+\)$/);
 }
 
-# These are all check that overloaded values rather than reference addresses
-# are what is getting tested.
+{
+    package Numify;
+    use overload (qw(0+ numify fallback 1));
+
+    sub new {
+       my $val = $_[1];
+       bless \$val, $_[0];
+    }
+
+    sub numify { ${$_[0]} }
+}
+
+# These all check that overloaded values, rather than reference addresses,
+# are what are getting tested.
 my ($two, $one, $un, $deux) = map {new Numify $_} 2, 1, 1, 2;
 my ($ein, $zwei) = (1, 2);
 
@@ -1852,6 +1857,9 @@ foreach my $op (qw(<=> == != < <= > >=)) {
            or die "open of \$iter_text gave ($!)\n";
        $subs{'<>'} = '<$iter_fh>';
        push @tests, [ $iter_fh, '<%s>', '(<>)', undef, [ 1, 1, 0 ], 1 ];
+       push @tests, [ $iter_fh,
+                     'local *CORE::GLOBAL::glob = sub {}; eval q|<%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/',
@@ -2186,7 +2194,7 @@ fresh_perl_is
 {
     package Justus;
     use overload '+' => 'justice';
-    eval {bless[]};
+    eval {"".bless[]};
     ::like $@, qr/^Can't resolve method "justice" overloading "\+" in p(?x:
                   )ackage "Justus" at /,
       'Error message when explicitly named overload method does not exist';
@@ -2195,7 +2203,7 @@ fresh_perl_is
     our @ISA = 'JustYou';
     package JustYou { use overload '+' => 'injustice'; }
     "JustUs"->${\"(+"};
-    eval {bless []};
+    eval {"".bless []};
     ::like $@, qr/^Stub found while resolving method "\?{3}" overloadin(?x:
                   )g "\+" in package "JustUs" at /,
       'Error message when sub stub is encountered';
@@ -2257,12 +2265,72 @@ sub fourteentative::abs { 'fourteen' }
     is abs $o, 'fourteen', 'isa changes can turn overloading on';
 }
 
+# no overload "fallback";
+{ package phake;
+  use overload fallback => 1, '""' => sub { 'arakas' };
+  no overload 'fallback';
+}
+$a = bless [], 'phake';
+is "$a", "arakas",
+    'no overload "fallback" does not stop overload from working';
+ok !eval { () = $a eq 'mpizeli'; 1 },
+    'no overload "fallback" resets fallback to undef on overloaded class';
+{ package ent; use overload fallback => 0, abs => sub{};
+  our@ISA = 'huorn';
+  package huorn;
+  use overload fallback => 1;
+  package ent;
+  no overload "fallback"; # disable previous declaration
+}
+$a = bless [], ent::;
+is eval {"$a"}, overload::StrVal($a),
+    'no overload undoes fallback declaration completetly'
+ or diag $@;
+
+# inherited fallback
+{
+ package pervyy;
+ our @ISA = 'vtoryy';
+ use overload "abs" =>=> sub {};
+ package vtoryy;
+ use overload fallback => 1, 'sin' =>=> sub{}
+}
+$a = bless [], pervyy::;
+is eval {"$a"}, overload::StrVal($a),
+ 'fallback is inherited by classes that have their own overloading'
+ or diag $@;
+
+# package separators in method names
+{
+ package mane;
+ use overload q\""\ => "bear::strength";
+ use overload bool  => "bear'bouillon";
+}
+@bear::ISA = 'food';
+sub food::strength { 'twine' }
+sub food::bouillon { 0 }
+$a = bless[], mane::;
+is eval { "$a" }, 'twine', ':: in method name' or diag $@;
+is eval { !$a  },   1,      "' in method name" or diag $@;
+
+# [perl #113050] Half of CPAN assumes fallback is under "()"
+{
+  package dodo;
+  use overload '+' => sub {};
+  no strict;
+  *{"dodo::()"} = sub{};
+  ${"dodo::()"} = 1;
+}
+$a = bless [],'dodo';
+is eval {"$a"}, overload::StrVal($a), 'fallback is stored under "()"';
+
+
 { # undefining the overload stash -- KEEP THIS TEST LAST
     package ant;
     use overload '+' => 'onion';
     $_ = \&overload::nil;
     undef %overload::;
-    bless[];
+    ()=0+bless[];
     ::ok(1, 'no crash when undefining %overload::');
 }