Add class_ok() and object_ok() to t/test.pl.

Change every existing instance of isa_ok() to use object_ok().  This is safe because
before this point, t/test.pl's isa_ok() only worked on objects.  lib/dbmt_common.pl is
the last hold out because it uses Test::More.

These are like isa_ok() but they also check if it's a class or an object.
This lets the core tests defend against outlandish bugs while allowing
t/test.pl to retain feature parity with Test::More.

diff --git a/t/lib/proxy_constant_subs.t b/t/lib/proxy_constant_subs.t
index e3cb41d..9e73006 100644 (file)
--- a/t/lib/proxy_constant_subs.t
+++ b/t/lib/proxy_constant_subs.t
@@ -23,10 +23,10 @@ foreach my $symbol (@symbols) {
        $ps = svref_2object(\*{"Fcntl::$symbol"});
        $ms = svref_2object(\*{"::$symbol"});
     }
-    isa_ok($ps, 'B::GV');
+    object_ok($ps, 'B::GV');
     is($ps->GvFLAGS() & GVf_IMPORTED_CV, 0,
        "GVf_IMPORTED_CV not set on original");
-    isa_ok($ms, 'B::GV');
+    object_ok($ms, 'B::GV');
     is($ms->GvFLAGS() & GVf_IMPORTED_CV, GVf_IMPORTED_CV,
        "GVf_IMPORTED_CV set on imported GV");
 }

diff --git a/t/mro/c3_with_overload.t b/t/mro/c3_with_overload.t
index 498ce2f..a75c31a 100644 (file)
--- a/t/mro/c3_with_overload.t
+++ b/t/mro/c3_with_overload.t
@@ -29,10 +29,10 @@ require q(./test.pl); plan(tests => 7);
 }
 
 my $x = InheritingFromOverloadedTest->new();
-isa_ok($x, 'InheritingFromOverloadedTest');
+object_ok($x, 'InheritingFromOverloadedTest');
 
 my $y = OverloadingTest->new();
-isa_ok($y, 'OverloadingTest');
+object_ok($y, 'OverloadingTest');
 
 is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
 is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');

diff --git a/t/mro/c3_with_overload_utf8.t b/t/mro/c3_with_overload_utf8.t
index 498ce2f..a75c31a 100644 (file)
--- a/t/mro/c3_with_overload_utf8.t
+++ b/t/mro/c3_with_overload_utf8.t
@@ -29,10 +29,10 @@ require q(./test.pl); plan(tests => 7);
 }
 
 my $x = InheritingFromOverloadedTest->new();
-isa_ok($x, 'InheritingFromOverloadedTest');
+object_ok($x, 'InheritingFromOverloadedTest');
 
 my $y = OverloadingTest->new();
-isa_ok($y, 'OverloadingTest');
+object_ok($y, 'OverloadingTest');
 
 is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
 is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');

diff --git a/t/mro/isa_c3.t b/t/mro/isa_c3.t
index 713d10e..dd129cf 100644 (file)
--- a/t/mro/isa_c3.t
+++ b/t/mro/isa_c3.t
@@ -64,6 +64,6 @@ foreach my $package (qw(klonk urkkk kapow kayo thwacke zzzzzwap whamm)) {
     is("@{mro::get_linear_isa($package)}", "@$isa", "\@ISA for $package");
 
     foreach my $class ($package, @$isa, 'UNIVERSAL') {
-       isa_ok($ref, $class, $package);
+       object_ok($ref, $class, $package);
     }
 }

diff --git a/t/mro/isa_c3_utf8.t b/t/mro/isa_c3_utf8.t
index 0e69e04..3e2e7a9 100644 (file)
--- a/t/mro/isa_c3_utf8.t
+++ b/t/mro/isa_c3_utf8.t
@@ -66,6 +66,6 @@ foreach my $package (qw(kഌoんḰ urḲḵｋ 캎oẃ к ṭ화ckэ Źzzzዟ
     is("@{mro::get_linear_isa($package)}", "@$isa", "\@ISA for $package");
 
     foreach my $class ($package, @$isa, 'UNIVERSAL') {
-       isa_ok($ref, $class, $package);
+       object_ok($ref, $class, $package);
     }
 }

diff --git a/t/mro/isa_dfs.t b/t/mro/isa_dfs.t
index 889ee6e..77c122e 100644 (file)
--- a/t/mro/isa_dfs.t
+++ b/t/mro/isa_dfs.t
@@ -60,6 +60,6 @@ foreach my $package (qw(klonk urkkk kapow kayo thwacke zzzzzwap whamm)) {
     is("@{mro::get_linear_isa($package)}", "@$isa", "\@ISA for $package");
 
     foreach my $class ($package, @$isa, 'UNIVERSAL') {
-       isa_ok($ref, $class, $package);
+       object_ok($ref, $class, $package);
     }
 }

diff --git a/t/mro/isa_dfs_utf8.t b/t/mro/isa_dfs_utf8.t
index b6608be..1c95eaa 100644 (file)
--- a/t/mro/isa_dfs_utf8.t
+++ b/t/mro/isa_dfs_utf8.t
@@ -62,6 +62,6 @@ foreach my $package (qw(kഌoんḰ urḲḵｋ 캎oẃ к ṭ화ckэ Źzzzዟ
     is("@{mro::get_linear_isa($package)}", "@$isa", "\@ISA for $package");
 
     foreach my $class ($package, @$isa, 'UNIVERSAL') {
-       isa_ok($ref, $class, $package);
+       object_ok($ref, $class, $package);
     }
 }

diff --git a/t/mro/next_edgecases.t b/t/mro/next_edgecases.t
index 7402ec9..e177d70 100644 (file)
--- a/t/mro/next_edgecases.t
+++ b/t/mro/next_edgecases.t
@@ -21,7 +21,7 @@ plan(tests => 12);
     # call the submethod in the direct instance
 
     my $foo = Foo->new();
-    isa_ok($foo, 'Foo');
+    object_ok($foo, 'Foo');
 
     can_ok($foo, 'bar');
     is($foo->bar(), 'Foo::bar', '... got the right return value');    
@@ -37,8 +37,8 @@ plan(tests => 12);
     }  
     
     my $bar = Bar->new();
-    isa_ok($bar, 'Bar');
-    isa_ok($bar, 'Foo');    
+    object_ok($bar, 'Bar');
+    object_ok($bar, 'Foo');    
     
     # test it working with with Sub::Name
     SKIP: {    
@@ -68,8 +68,8 @@ plan(tests => 12);
     }      
     
     my $baz = Baz->new();
-    isa_ok($baz, 'Baz');
-    isa_ok($baz, 'Foo');    
+    object_ok($baz, 'Baz');
+    object_ok($baz, 'Foo');    
     
     {
         my $m = sub { (shift)->next::method() };

diff --git a/t/mro/next_edgecases_utf8.t b/t/mro/next_edgecases_utf8.t
index bd461c7..ba6ff8b 100644 (file)
--- a/t/mro/next_edgecases_utf8.t
+++ b/t/mro/next_edgecases_utf8.t
@@ -24,7 +24,7 @@ plan(tests => 12);
     # call the submethod in the direct instance
 
     my $foo = ᕘ->new();
-    isa_ok($foo, 'ᕘ');
+    object_ok($foo, 'ᕘ');
 
     can_ok($foo, 'ƚ');
     is($foo->ƚ(), 'ᕘ::ƚ', '... got the right return value');    
@@ -40,8 +40,8 @@ plan(tests => 12);
     }  
     
     my $bar = Baɾ->new();
-    isa_ok($bar, 'Baɾ');
-    isa_ok($bar, 'ᕘ');    
+    object_ok($bar, 'Baɾ');
+    object_ok($bar, 'ᕘ');    
     
     # test it working with with Sub::Name
     SKIP: {    
@@ -71,8 +71,8 @@ plan(tests => 12);
     }      
     
     my $baz = બʑ->new();
-    isa_ok($baz, 'બʑ');
-    isa_ok($baz, 'ᕘ');    
+    object_ok($baz, 'બʑ');
+    object_ok($baz, 'ᕘ');    
     
     {
         my $m = sub { (shift)->next::method() };

diff --git a/t/mro/overload_c3.t b/t/mro/overload_c3.t
index a62e631..db2b1ec 100644 (file)
--- a/t/mro/overload_c3.t
+++ b/t/mro/overload_c3.t
@@ -35,10 +35,10 @@ require q(./test.pl); plan(tests => 7);
 }
 
 my $x = InheritingFromOverloadedTest->new();
-isa_ok($x, 'InheritingFromOverloadedTest');
+object_ok($x, 'InheritingFromOverloadedTest');
 
 my $y = OverloadingTest->new();
-isa_ok($y, 'OverloadingTest');
+object_ok($y, 'OverloadingTest');
 
 is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
 is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');

diff --git a/t/mro/overload_c3_utf8.t b/t/mro/overload_c3_utf8.t
index 5a483ef..bcb9f70 100644 (file)
--- a/t/mro/overload_c3_utf8.t
+++ b/t/mro/overload_c3_utf8.t
@@ -38,10 +38,10 @@ require q(./test.pl); plan(tests => 7);
 }
 
 my $x = 읺ҎꀀḮṆᵷꜰ롬ᵕveŔŁoad엗텟ᵵ->ネᚹ();
-isa_ok($x, '읺ҎꀀḮṆᵷꜰ롬ᵕveŔŁoad엗텟ᵵ');
+object_ok($x, '읺ҎꀀḮṆᵷꜰ롬ᵕveŔŁoad엗텟ᵵ');
 
 my $y = Ov에rꪩࡃᛝＴeŝṱ->ネᚹ();
-isa_ok($y, 'Ov에rꪩࡃᛝＴeŝṱ');
+object_ok($y, 'Ov에rꪩࡃᛝＴeŝṱ');
 
 is("$x", '읺ҎꀀḮṆᵷꜰ롬ᵕveŔŁoad엗텟ᵵ stringified', '... got the right value when stringifing');
 is("$y", 'Ov에rꪩࡃᛝＴeŝṱ stringified', '... got the right value when stringifing');

diff --git a/t/mro/overload_dfs.t b/t/mro/overload_dfs.t
index 89f11d0..5943c85 100644 (file)
--- a/t/mro/overload_dfs.t
+++ b/t/mro/overload_dfs.t
@@ -35,10 +35,10 @@ require q(./test.pl); plan(tests => 7);
 }
 
 my $x = InheritingFromOverloadedTest->new();
-isa_ok($x, 'InheritingFromOverloadedTest');
+object_ok($x, 'InheritingFromOverloadedTest');
 
 my $y = OverloadingTest->new();
-isa_ok($y, 'OverloadingTest');
+object_ok($y, 'OverloadingTest');
 
 is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
 is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');

diff --git a/t/mro/package_aliases.t b/t/mro/package_aliases.t
index b08e8ed..3bc3c8f 100644 (file)
--- a/t/mro/package_aliases.t
+++ b/t/mro/package_aliases.t
@@ -30,8 +30,8 @@ plan(tests => 52);
 ok (Old->isa (New::), 'Old inherits from New');
 ok (New->isa (Old::), 'New inherits from Old');
 
-isa_ok (bless ({}, Old::), New::, 'Old object');
-isa_ok (bless ({}, New::), Old::, 'New object');
+object_ok (bless ({}, Old::), New::, 'Old object');
+object_ok (bless ({}, New::), Old::, 'New object');
 
 
 # Test that replacing a package by assigning to an existing glob

diff --git a/t/mro/package_aliases_utf8.t b/t/mro/package_aliases_utf8.t
index ae214e5..0106154 100644 (file)
--- a/t/mro/package_aliases_utf8.t
+++ b/t/mro/package_aliases_utf8.t
@@ -33,8 +33,8 @@ plan(tests => 52);
 ok (ऑlㄉ->isa(Ｎeẁ::), 'ऑlㄉ inherits from Ｎeẁ');
 ok (Ｎeẁ->isa(ऑlㄉ::), 'Ｎeẁ inherits from ऑlㄉ');
 
-isa_ok (bless ({}, ऑlㄉ::), Ｎeẁ::, 'ऑlㄉ object');
-isa_ok (bless ({}, Ｎeẁ::), ऑlㄉ::, 'Ｎeẁ object');
+object_ok (bless ({}, ऑlㄉ::), Ｎeẁ::, 'ऑlㄉ object');
+object_ok (bless ({}, Ｎeẁ::), ऑlㄉ::, 'Ｎeẁ object');
 
 
 # Test that replacing a package by assigning to an existing glob

diff --git a/t/op/qr.t b/t/op/qr.t
index 13438de..90535d0 100644 (file)
--- a/t/op/qr.t
+++ b/t/op/qr.t
@@ -11,9 +11,9 @@ sub r {
 }
 
 my $a = r();
-isa_ok($a, 'Regexp');
+object_ok($a, 'Regexp');
 my $b = r();
-isa_ok($b, 'Regexp');
+object_ok($b, 'Regexp');
 
 my $b1 = $b;
 
@@ -21,9 +21,9 @@ isnt($a + 0, $b + 0, 'Not the same object');
 
 bless $b, 'Pie';
 
-isa_ok($b, 'Pie');
-isa_ok($a, 'Regexp');
-isa_ok($b1, 'Pie');
+object_ok($b, 'Pie');
+object_ok($a, 'Regexp');
+object_ok($b1, 'Pie');
 
 my $c = r();
 like("$c", qr/Good/);
@@ -43,16 +43,16 @@ is($$d1, 'Bad');
 # Assignment to an implicitly blessed Regexp object retains the class
 # (No different from direct value assignment to any other blessed SV
 
-isa_ok($d, 'Regexp');
+object_ok($d, 'Regexp');
 like("$d", qr/\ARegexp=SCALAR\(0x[0-9a-f]+\)\z/);
 
 # As does an explicitly blessed Regexp object.
 
 my $e = bless qr/Faux Pie/, 'Stew';
 
-isa_ok($e, 'Stew');
+object_ok($e, 'Stew');
 $$e = 'Fake!';
 
 is($$e, 'Fake!');
-isa_ok($e, 'Stew');
+object_ok($e, 'Stew');
 like("$e", qr/\Stew=SCALAR\(0x[0-9a-f]+\)\z/);

diff --git a/t/op/stash.t b/t/op/stash.t
index e7d6609..9e223eb 100644 (file)
--- a/t/op/stash.t
+++ b/t/op/stash.t
@@ -92,7 +92,7 @@ SKIP: {
     delete $one::{one};
     my $gv = b($sub)->GV;
 
-    isa_ok( $gv, "B::GV", "deleted stash entry leaves CV with valid GV");
+    object_ok( $gv, "B::GV", "deleted stash entry leaves CV with valid GV");
     is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
     is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
     is( eval { $gv->STASH->NAME }, "one", "...but leaves stash intact");
@@ -104,7 +104,7 @@ SKIP: {
     %two:: = ();
     $gv = b($sub)->GV;
 
-    isa_ok( $gv, "B::GV", "cleared stash leaves CV with valid GV");
+    object_ok( $gv, "B::GV", "cleared stash leaves CV with valid GV");
     is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
     is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
     is( eval { $gv->STASH->NAME }, "two", "...but leaves stash intact");
@@ -116,7 +116,7 @@ SKIP: {
     undef %three::;
     $gv = b($sub)->GV;
 
-    isa_ok( $gv, "B::GV", "undefed stash leaves CV with valid GV");
+    object_ok( $gv, "B::GV", "undefed stash leaves CV with valid GV");
     is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
     is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
     is( eval { $gv->STASH->NAME }, "__ANON__", "...and an __ANON__ stash");

diff --git a/t/re/pat_advanced.t b/t/re/pat_advanced.t
index 6159b7b..4d88190 100644 (file)
--- a/t/re/pat_advanced.t
+++ b/t/re/pat_advanced.t
@@ -2057,7 +2057,7 @@ EOP
                  (?<=[=&]) (?=.)
             )}iox';
        is($@, '', $message);
-       isa_ok($r, 'Regexp', $message);
+       object_ok($r, 'Regexp', $message);
     }
 
     # RT #82610

diff --git a/t/test.pl b/t/test.pl
index c24846d..a287bc2 100644 (file)
--- a/t/test.pl
+++ b/t/test.pl
@@ -1064,7 +1064,7 @@ sub can_ok ($@) {
 }
 
 
-# Call $class->new( @$args ); and run the result through isa_ok.
+# Call $class->new( @$args ); and run the result through object_ok.
 # See Test::More::new_ok
 sub new_ok {
     my($class, $args, $obj_name) = @_;
@@ -1078,7 +1078,7 @@ sub new_ok {
     my $error = $@;
 
     if($ok) {
-        isa_ok($obj, $class, $object_name);
+        object_ok($obj, $class, $object_name);
     }
     else {
         ok( 0, "new() died" );
@@ -1140,6 +1140,34 @@ WHOA
     _ok( !$diag, _where(), $name );
 }
 
+
+sub class_ok {
+    my($class, $isa, $class_name) = @_;
+
+    # Written so as to count as one test
+    local $Level = $Level + 1;
+    if( ref $class ) {
+        ok( 0, "$class is a refrence, not a class name" );
+    }
+    else {
+        isa_ok($class, $isa, $class_name);
+    }
+}
+
+
+sub object_ok {
+    my($obj, $isa, $obj_name) = @_;
+
+    local $Level = $Level + 1;
+    if( !ref $obj ) {
+        ok( 0, "$obj is not a reference" );
+    }
+    else {
+        isa_ok($obj, $isa, $obj_name);
+    }
+}
+
+
 # Purposefully avoiding a closure.
 sub __capture {
     push @::__capture, join "", @_;

diff --git a/t/test_pl/can_isa_ok.t b/t/test_pl/can_isa_ok.t
index bb24f56..081d3e5 100644 (file)
--- a/t/test_pl/can_isa_ok.t
+++ b/t/test_pl/can_isa_ok.t
@@ -5,7 +5,7 @@
 use strict;
 use warnings;
 
-BEGIN { require "t/test.pl"; }
+BEGIN { require "test.pl"; }
 
 require Test::More;
 
@@ -41,4 +41,23 @@ isa_ok(\42, 'SCALAR');
 }
 
 
+note "object/class_ok"; {
+    {
+        package Child;
+        our @ISA = qw(Parent);
+    }
+
+    {
+        package Parent;
+        sub new { bless {}, shift }
+    }
+
+    # Unfortunately we can't usefully test the failure case without
+    # significantly modifying test.pl
+    class_ok "Child", "Parent";
+    class_ok "Parent", "Parent";
+    object_ok( Parent->new, "Parent" );
+    object_ok( Child->new, "Parent" );
+}
+
 done_testing;

diff --git a/t/uni/stash.t b/t/uni/stash.t
index f6e8c42..168b93c 100644 (file)
--- a/t/uni/stash.t
+++ b/t/uni/stash.t
@@ -84,7 +84,7 @@ plan( tests => 58 );
         delete $온ꪵ::{온ꪵ};
         my $gv = b($sub)->GV;
     
-        isa_ok( $gv, "B::GV", "deleted stash entry leaves CV with valid GV");
+        object_ok( $gv, "B::GV", "deleted stash entry leaves CV with valid GV");
         is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
         is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
         is( eval { $gv->STASH->NAME }, "온ꪵ", "...but leaves stash intact");
@@ -96,7 +96,7 @@ plan( tests => 58 );
         %tꖿ:: = ();
         $gv = b($sub)->GV;
     
-        isa_ok( $gv, "B::GV", "cleared stash leaves CV with valid GV");
+        object_ok( $gv, "B::GV", "cleared stash leaves CV with valid GV");
         is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
         is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
         is( eval { $gv->STASH->NAME }, "tꖿ", "...but leaves stash intact");
@@ -108,7 +108,7 @@ plan( tests => 58 );
         undef %ᖟ레ￇ::;
         $gv = b($sub)->GV;
     
-        isa_ok( $gv, "B::GV", "undefed stash leaves CV with valid GV");
+        object_ok( $gv, "B::GV", "undefed stash leaves CV with valid GV");
         is( b($sub)->CvFLAGS & $CVf_ANON, $CVf_ANON, "...and CVf_ANON set");
         is( eval { $gv->NAME }, "__ANON__", "...and an __ANON__ name");
         is( eval { $gv->STASH->NAME }, "__ANON__", "...and an __ANON__ stash");