Tests for DOES/isa/can with UTF8 and embedded nuls

2 files changed, 184 insertions, 1 deletions

diff --git a/t/op/universal.t b/t/op/universal.t
index dcef480398..9999ca1971 100644
--- a/t/op/universal.t
+++ b/t/op/universal.t
@@ -10,7 +10,7 @@ BEGIN {
     require "./test.pl";
 }
 
-plan tests => 125;
+plan tests => 129;
 
 $a = {};
 bless $a, "Bob";
@@ -59,6 +59,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 +70,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
@@ -220,6 +223,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');
diff --git a/t/uni/universal.t b/t/uni/universal.t
new file mode 100644
index 0000000000..c53f85382f
--- /dev/null
+++ b/t/uni/universal.t
@@ -0,0 +1,177 @@
+#!./perl
+#
+# check UNIVERSAL
+#
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+    $| = 1;
+    require "./test.pl";
+}
+
+use utf8;
+use open qw( :utf8 :std );
+
+plan tests => 93;
+
+$a = {};
+bless $a, "Bòb";
+ok $a->isa("Bòb");
+
+package Hùmàn;
+sub èàt {}
+
+package Fèmàlè;
+@ISA=qw(Hùmàn);
+
+package Àlìcè;
+@ISA=qw(Bòb Fèmàlè);
+sub sìng;
+sub drìnk { return "drinking " . $_[1]  }
+sub nèw { bless {} }
+
+$Àlìcè::VERSION = 2.718;
+
+{
+    package Cèdrìc;
+    our @ISA;
+    use base qw(Hùmàn);
+}
+
+{
+    package Prògràmmèr;
+    our $VERSION = 1.667;
+
+    sub wrìtè_perl { 1 }
+}
+
+package main;
+
+$a = nèw Àlìcè;
+
+ok $a->isa("Àlìcè");
+TODO: {
+    local $TODO = "mro";
+    ok $a->isa("main::Àlìcè");    # check that alternate class names work
+}
+ok(("main::Àlìcè"->nèw)->isa("Àlìcè"));
+
+ok $a->isa("Bòb");
+TODO: {
+    local $TODO = "mro";
+    ok $a->isa("main::Bòb");
+}
+
+ok $a->isa("Fèmàlè");
+
+ok $a->isa("Hùmàn");
+
+ok ! $a->isa("Màlè");
+
+ok ! $a->isa('Prògràmmèr');
+
+ok $a->isa("HASH");
+
+ok $a->can("èàt");
+ok ! $a->can("sleep");
+ok my $ref = $a->can("drìnk");        # returns a coderef
+is $a->$ref("tèà"), "drinking tèà"; # ... which works
+ok $ref = $a->can("sìng");
+eval { $a->$ref() };
+ok $@;                                # ... but not if no actual subroutine
+
+ok $a->can("VERSION");
+cmp_ok eval { $a->VERSION }, '==', 2.718;
+ok ! (eval { $a->VERSION(2.719) });
+like $@, qr/^Àlìcè version 2.719 required--this is only version 2.718 at /u;
+
+ok (!Cèdrìc->isa('Prògràmmèr'));
+
+ok (Cèdrìc->isa('Hùmàn'));
+
+push(@Cèdrìc::ISA,'Prògràmmèr');
+
+ok (Cèdrìc->isa('Prògràmmèr'));
+
+{
+    package Àlìcè;
+    base::->import('Prògràmmèr');
+}
+
+ok $a->isa('Prògràmmèr');
+ok $a->isa("Fèmàlè");
+
+@Cèdrìc::ISA = qw(Bòb);
+
+ok (!Cèdrìc->isa('Prògràmmèr'));
+
+my $b = 'abc';
+my @refs = qw(SCALAR SCALAR     LVALUE      GLOB ARRAY HASH CODE);
+my @vals = (  \$b,   \3.14, \substr($b,1,1), \*b,  [],  {}, sub {} );
+for ($p=0; $p < @refs; $p++) {
+    for ($q=0; $q < @vals; $q++) {
+        is UNIVERSAL::isa($vals[$p], $refs[$q]), ($p==$q or $p+$q==1);
+    };
+};
+
+
+ok UNIVERSAL::isa(Àlìcè => "UNIVERSAL");
+
+cmp_ok UNIVERSAL::can(Àlìcè => "can"), '==', \&UNIVERSAL::can;
+
+eval 'sub UNIVERSAL::slèèp {}';
+ok $a->can("slèèp");
+
+{
+    package Pìckùp;
+    use UNIVERSAL qw( isa can VERSION );
+
+    ::ok isa "Pìckùp", UNIVERSAL;
+    ::cmp_ok can( "Pìckùp", "can" ), '==', \&UNIVERSAL::can;
+    ::ok VERSION "UNIVERSAL" ;
+}
+
+package Fòò;
+
+sub DOES { 1 }
+
+package Bàr;
+
+@Bàr::ISA = 'Fòò';
+
+package Bàz;
+
+package main;
+ok( Fòò->DOES( 'bàr' ), 'DOES() should call DOES() on class' );
+ok( Bàr->DOES( 'Bàr' ), '... and should fall back to isa()' );
+ok( Bàr->DOES( 'Fòò' ), '... even when inherited' );
+ok( Bàz->DOES( 'Bàz' ), '... even without inheriting any other DOES()' );
+ok( ! Bàz->DOES( 'Fòò' ), '... returning true or false appropriately' );
+
+package Pìg;
+package Bòdìnè;
+Bòdìnè->isa('Pìg');
+
+package main;
+eval { UNIVERSAL::DOES([], "fòò") };
+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("NòSùchPàckàgè::fòò"), undef);
+
+@splàtt::ISA = 'zlòpp';
+ok (splàtt->isa('zlòpp'));
+ok (!splàtt->isa('plòp'));
+
+# This should reset the ->isa lookup cache
+@splàtt::ISA = 'plòp';
+# And here is the new truth.
+ok (!splàtt->isa('zlòpp'));
+ok (splàtt->isa('plòp'));
+
+