[perl #68108] : also fix if/else constant folding

[p5sagit/p5-mst-13.2.git] / t / op / universal.t

diff --git a/t/op/universal.t b/t/op/universal.t
old mode 100755 (executable)
new mode 100644 (file)
index 1850127..a24d7aa
--- a/t/op/universal.t
+++ b/t/op/universal.t
@@ -10,7 +10,7 @@ BEGIN {
     require "./test.pl";
 }
 
-plan tests => 104;
+plan tests => 123;
 
 $a = {};
 bless $a, "Bob";
@@ -114,7 +114,7 @@ ok ! $a->can("export_tags");        # a method in Exporter
 cmp_ok eval { $a->VERSION }, '==', 2.718;
 
 ok ! (eval { $a->VERSION(2.719) });
-like $@, qr/^Alice version 2.719 \(v2\.719\.0\) required--this is only version 2.718 \(v2\.718\.0\) at /;
+like $@, qr/^Alice version 2.719 required--this is only version 2.718 at /;
 
 ok (eval { $a->VERSION(2.718) });
 is $@, '';
@@ -123,9 +123,9 @@ my $subs = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
 ## The test for import here is *not* because we want to ensure that UNIVERSAL
 ## can always import; it is an historical accident that UNIVERSAL can import.
 if ('a' lt 'A') {
-    is $subs, "can import isa VERSION";
+    is $subs, "can import isa DOES VERSION";
 } else {
-    is $subs, "VERSION can import isa";
+    is $subs, "DOES VERSION can import isa";
 }
 
 ok $a->isa("UNIVERSAL");
@@ -146,9 +146,9 @@ ok $a->isa("UNIVERSAL");
 my $sub2 = join ' ', sort grep { defined &{"UNIVERSAL::$_"} } keys %UNIVERSAL::;
 # XXX import being here is really a bug
 if ('a' lt 'A') {
-    is $sub2, "can import isa VERSION";
+    is $sub2, "can import isa DOES VERSION";
 } else {
-    is $sub2, "VERSION can import isa";
+    is $sub2, "DOES VERSION can import isa";
 }
 
 eval 'sub UNIVERSAL::sleep {}';
@@ -200,3 +200,110 @@ is $@, '';
 # This segfaulted in a blead.
 fresh_perl_is('package Foo; Foo->VERSION;  print "ok"', 'ok');
 
+package Foo;
+
+sub DOES { 1 }
+
+package Bar;
+
+@Bar::ISA = 'Foo';
+
+package Baz;
+
+package main;
+ok( Foo->DOES( 'bar' ), 'DOES() should call DOES() on class' );
+ok( Bar->DOES( 'Bar' ), '... and should fall back to isa()' );
+ok( Bar->DOES( 'Foo' ), '... even when inherited' );
+ok( Baz->DOES( 'Baz' ), '... even without inheriting any other DOES()' );
+ok( ! Baz->DOES( 'Foo' ), '... returning true or false appropriately' );
+
+package Pig;
+package Bodine;
+Bodine->isa('Pig');
+*isa = \&UNIVERSAL::isa;
+eval { isa({}, 'HASH') };
+::is($@, '', "*isa correctly found");
+
+package main;
+eval { UNIVERSAL::DOES([], "foo") };
+like( $@, qr/Can't call method "DOES" on unblessed reference/,
+    'DOES call error message says DOES, not isa' );
+
+# Tests for can seem to be split between here and method.t
+# Add the verbatim perl code mentioned in the comments of
+# http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2001-05/msg01710.html
+# but never actually tested.
+is(UNIVERSAL->can("NoSuchPackage::foo"), undef);
+
+@splatt::ISA = 'zlopp';
+ok (splatt->isa('zlopp'));
+ok (!splatt->isa('plop'));
+
+# This should reset the ->isa lookup cache
+@splatt::ISA = 'plop';
+# And here is the new truth.
+ok (!splatt->isa('zlopp'));
+ok (splatt->isa('plop'));
+
+use warnings "deprecated";
+{
+    my $m;
+    local $SIG{__WARN__} = sub { $m = $_[0] };
+    eval "use UNIVERSAL";
+    like($m, qr/^UNIVERSAL->import is deprecated/,
+       "deprecation warning for UNIVERSAL->import");
+}
+
+# Test: [perl #66112]: change @ISA inside  sub isa
+{
+    package RT66112::A;
+
+    package RT66112::B;
+
+    sub isa {
+       my $self = shift;
+       @ISA = qw/RT66112::A/;
+       return $self->SUPER::isa(@_);
+    }
+
+    package RT66112::C;
+
+    package RT66112::D;
+
+    sub isa {
+       my $self = shift;
+       @RT66112::E::ISA = qw/RT66112::A/;
+       return $self->SUPER::isa(@_);
+    }
+
+    package RT66112::E;
+
+    package main;
+
+    @RT66112::B::ISA = qw//;
+    @RT66112::C::ISA = qw/RT66112::B/;
+    @RT66112::T1::ISA = qw/RT66112::C/;
+    ok(RT66112::T1->isa('RT66112::C'), "modify \@ISA in isa (RT66112::T1 isa RT66112::C)");
+
+    @RT66112::B::ISA = qw//;
+    @RT66112::C::ISA = qw/RT66112::B/;
+    @RT66112::T2::ISA = qw/RT66112::C/;
+    ok(RT66112::T2->isa('RT66112::B'), "modify \@ISA in isa (RT66112::T2 isa RT66112::B)");
+
+    @RT66112::B::ISA = qw//;
+    @RT66112::C::ISA = qw/RT66112::B/;
+    @RT66112::T3::ISA = qw/RT66112::C/;
+    ok(RT66112::T3->isa('RT66112::A'), "modify \@ISA in isa (RT66112::T3 isa RT66112::A)");
+
+    @RT66112::E::ISA = qw/RT66112::D/;
+    @RT66112::T4::ISA = qw/RT66112::E/;
+    ok(RT66112::T4->isa('RT66112::E'), "modify \@ISA in isa (RT66112::T4 isa RT66112::E)");
+
+    @RT66112::E::ISA = qw/RT66112::D/;
+    @RT66112::T5::ISA = qw/RT66112::E/;
+    ok(! RT66112::T5->isa('RT66112::D'), "modify \@ISA in isa (RT66112::T5 not isa RT66112::D)");
+
+    @RT66112::E::ISA = qw/RT66112::D/;
+    @RT66112::T6::ISA = qw/RT66112::E/;
+    ok(RT66112::T6->isa('RT66112::A'), "modify \@ISA in isa (RT66112::T6 isa RT66112::A)");
+}