Mailling list archaeology, restoring old content

[perl5.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 f1c0323..4c277c3
--- a/t/op/universal.t
+++ b/t/op/universal.t
@@ -5,12 +5,13 @@
 
 BEGIN {
     chdir 't' if -d 't';
-    @INC = '../lib';
+    require './test.pl';
+    set_up_inc(qw '../lib ../dist/base/lib');
     $| = 1;
     require "./test.pl";
 }
 
-plan tests => 116;
+plan tests => 143;
 
 $a = {};
 bless $a, "Bob";
@@ -59,6 +60,8 @@ ok $a->isa("main::Bob");
 
 ok $a->isa("Female");
 
+ok ! $a->isa("Female\0NOT REALLY!"), "->isa is nul-clean.";
+
 ok $a->isa("Human");
 
 ok ! $a->isa("Male");
@@ -68,6 +71,7 @@ ok ! $a->isa('Programmer');
 ok $a->isa("HASH");
 
 ok $a->can("eat");
+ok ! $a->can("eat\0Except not!"), "->can is nul-clean.";
 ok ! $a->can("sleep");
 ok my $ref = $a->can("drink");        # returns a coderef
 is $a->$ref("tea"), "drinking tea"; # ... which works
@@ -104,7 +108,14 @@ for ($p=0; $p < @refs; $p++) {
     };
 };
 
-ok ! UNIVERSAL::can(23, "can");
+ok UNIVERSAL::can(23, "can");
+++${"23::foo"};
+ok UNIVERSAL::can("23", "can"), '"23" can can when the pack exists';
+ok UNIVERSAL::can(23, "can"), '23 can can when the pack exists';
+sub IO::Handle::turn {}
+ok UNIVERSAL::can(*STDOUT, 'turn'), 'globs with IOs can';
+ok UNIVERSAL::can(\*STDOUT, 'turn'), 'globrefs with IOs can';
+ok UNIVERSAL::can("STDOUT", 'turn'), 'IO barewords can';
 
 ok $a->can("VERSION");
 
@@ -119,13 +130,18 @@ like $@, qr/^Alice version 2.719 required--this is only version 2.718 at /;
 ok (eval { $a->VERSION(2.718) });
 is $@, '';
 
+ok ! (eval { $a->VERSION("version") });
+like $@, qr/^Invalid version format/;
+
+$aversion::VERSION = "version";
+ok ! (eval { aversion->VERSION(2.719) });
+like $@, qr/^Invalid version format/;
+
 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 DOES VERSION";
+    is $subs, "can isa DOES VERSION";
 } else {
-    is $subs, "DOES VERSION can import isa";
+    is $subs, "DOES VERSION can isa";
 }
 
 ok $a->isa("UNIVERSAL");
@@ -154,22 +170,13 @@ if ('a' lt 'A') {
 eval 'sub UNIVERSAL::sleep {}';
 ok $a->can("sleep");
 
-ok ! UNIVERSAL::can($b, "can");
+ok UNIVERSAL::can($b, "can");
 
 ok ! $a->can("export_tags");   # a method in Exporter
 
 ok ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH');
 
 {
-    package Pickup;
-    use UNIVERSAL qw( isa can VERSION );
-
-    ::ok isa "Pickup", UNIVERSAL;
-    ::cmp_ok can( "Pickup", "can" ), '==', \&UNIVERSAL::can;
-    ::ok VERSION "UNIVERSAL" ;
-}
-
-{
     # test isa() and can() on magic variables
     "Human" =~ /(.*)/;
     ok $1->isa("Human");
@@ -200,6 +207,9 @@ is $@, '';
 # This segfaulted in a blead.
 fresh_perl_is('package Foo; Foo->VERSION;  print "ok"', 'ok');
 
+# So did this.
+fresh_perl_is('$:; UNIVERSAL::isa(":","Unicode::String");print "ok"','ok');
+
 package Foo;
 
 sub DOES { 1 }
@@ -217,6 +227,9 @@ 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' );
 
+ok( ! "T"->DOES( "T\0" ), 'DOES() is nul-clean' );
+ok( ! Baz->DOES( "Baz\0Boy howdy" ), 'DOES() is nul-clean' );
+
 package Pig;
 package Bodine;
 Bodine->isa('Pig');
@@ -231,7 +244,8 @@ like( $@, qr/Can't call method "DOES" on unblessed reference/,
 
 # 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
+# Message-ID: E14ufZD-0007kD-00@libra.cus.cam.ac.uk
+# https://www.nntp.perl.org/group/perl.perl5.porters/2001/05/msg35327.html
 # but never actually tested.
 is(UNIVERSAL->can("NoSuchPackage::foo"), undef);
 
@@ -245,3 +259,88 @@ ok (!splatt->isa('plop'));
 ok (!splatt->isa('zlopp'));
 ok (splatt->isa('plop'));
 
+use warnings "deprecated";
+{
+    my $m;
+    local $SIG{__WARN__} = sub { $m = $_[0] };
+    eval "use UNIVERSAL 'can'";
+    like($@, qr/^UNIVERSAL does not export anything\b/,
+       "error for UNIVERSAL->import('can')");
+    is($m, undef,
+       "no deprecation warning for UNIVERSAL->import('can')");
+
+         undef $m;
+    eval "use UNIVERSAL";
+    is($@, "",
+       "no error for UNIVERSAL->import");
+    is($m, undef,
+       "no 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)") or require mro, diag "@{mro::get_linear_isa('RT66112::T3')}";
+
+    @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)");
+}
+
+ok(Undeclared->can("can"));
+sub Undeclared::foo { }
+ok(Undeclared->can("foo"));
+ok(!Undeclared->can("something_else"));
+
+ok(Undeclared->isa("UNIVERSAL"));
+
+# keep this at the end to avoid messing up earlier tests, since it modifies
+# @UNIVERSAL::ISA
+@UNIVERSAL::ISA = ('UniversalParent');
+{ package UniversalIsaTest1; }
+ok(UniversalIsaTest1->isa('UniversalParent'));
+ok(UniversalIsaTest2->isa('UniversalParent'));