diff options
Diffstat (limited to 't/18_driver.t')
| -rw-r--r-- | t/18_driver.t | 127 |
1 files changed, 127 insertions, 0 deletions
diff --git a/t/18_driver.t b/t/18_driver.t new file mode 100644 index 0000000..3cf1c2b --- /dev/null +++ b/t/18_driver.t @@ -0,0 +1,127 @@ +#!/usr/bin/perl + +use strict; +BEGIN { + $| = 1; + $^W = 1; + $ENV{PERL_PARAMS_UTIL_PP} ||= 1; +} + +use Test::More tests => 91; +use File::Spec::Functions ':ALL'; +BEGIN { + ok( ! defined &_CLASSISA, '_CLASSISA does not exist' ); + ok( ! defined &_SUBCLASS, '_SUBCLASS does not exist' ); + ok( ! defined &_DRIVER, '_DRIVER does not exist' ); + use_ok('Params::Util', qw(_CLASSISA _SUBCLASS _DRIVER)); + ok( defined &_CLASSISA, '_CLASSISA imported ok' ); + ok( defined &_SUBCLASS, '_SUBCLASS imported ok' ); + ok( defined &_DRIVER, '_DRIVER imported ok' ); +} + +# Import refaddr to make certain we have it +use Scalar::Util 'refaddr'; + + + + + +##################################################################### +# Preparing + +my $A = catfile( 't', 'driver', 'A.pm' ); +ok( -f $A, 'A exists' ); +my $B = catfile( 't', 'driver', 'My_B.pm' ); +ok( -f $B, 'My_B exists' ); +my $C = catfile( 't', 'driver', 'C.pm' ); +ok( ! -f $C, 'C does not exist' ); +my $D = catfile( 't', 'driver', 'D.pm' ); +ok( -f $D, 'D does not exist' ); +my $E = catfile( 't', 'driver', 'E.pm' ); +ok( -f $E, 'E does not exist' ); +my $F = catfile( 't', 'driver', 'F.pm' ); +ok( -f $F, 'F does not exist' ); + +unshift @INC, catdir( 't', 'driver' ); + + + + + +##################################################################### +# Things that are not file handles + +foreach ( + undef, '', ' ', 'foo bar', 1, 0, -1, 1.23, + [], {}, \'', bless( {}, "foo" ) +) { + is( _CLASSISA($_, 'A'), undef, 'Non-classisa returns undef' ); + is( _SUBCLASS($_, 'A'), undef, 'Non-subclass returns undef' ); + is( _DRIVER($_, 'A'), undef, 'Non-driver returns undef' ); +} + + + + + +##################################################################### +# Sample Classes + +# classisa should not load classes +is( _CLASSISA('A', 'A'), 'A', 'A: Driver base class is undef' ); +is( _CLASSISA('My_B', 'A'), undef, 'B: Good driver returns ok' ); +is( _CLASSISA('My_B', 'H'), undef, 'B: Good driver return undef for incorrect base' ); +is( _CLASSISA('C', 'A'), undef, 'C: Non-existant driver is undef' ); +is( _CLASSISA('D', 'A'), undef, 'D: Broken driver is undef' ); +is( _CLASSISA('E', 'A'), undef, 'E: Not a driver returns undef' ); +is( _CLASSISA('F', 'A'), undef, 'F: Faked isa returns ok' ); + +# classisa should not load classes +is( _SUBCLASS('A', 'A'), undef, 'A: Driver base class is undef' ); +is( _SUBCLASS('My_B', 'A'), undef, 'B: Good driver returns ok' ); +is( _SUBCLASS('My_B', 'H'), undef, 'B: Good driver return undef for incorrect base' ); +is( _SUBCLASS('C', 'A'), undef, 'C: Non-existant driver is undef' ); +is( _SUBCLASS('D', 'A'), undef, 'D: Broken driver is undef' ); +is( _SUBCLASS('E', 'A'), undef, 'E: Not a driver returns undef' ); +is( _SUBCLASS('F', 'A'), undef, 'F: Faked isa returns ok' ); + +# The base class itself is not a driver +is( _DRIVER('A', 'A'), undef, 'A: Driver base class is undef' ); +ok( $A::VERSION, 'A: Class is loaded ok' ); +is( _DRIVER('My_B', 'A'), 'My_B', 'B: Good driver returns ok' ); +is( _DRIVER('My_B', 'H'), undef, 'B: Good driver return undef for incorrect base' ); +ok( $My_B::VERSION, 'B: Class is loaded ok' ); +is( _DRIVER('C', 'A'), undef, 'C: Non-existant driver is undef' ); +is( _DRIVER('D', 'A'), undef, 'D: Broken driver is undef' ); +is( _DRIVER('E', 'A'), undef, 'E: Not a driver returns undef' ); +is( _DRIVER('F', 'A'), 'F', 'F: Faked isa returns ok' ); + +# Repeat for classisa +is( _CLASSISA('A', 'A'), 'A', 'A: Driver base class is undef' ); +is( _CLASSISA('My_B', 'A'), 'My_B', 'B: Good driver returns ok' ); +is( _CLASSISA('My_B', 'H'), undef, 'B: Good driver return undef for incorrect base' ); +is( _CLASSISA('C', 'A'), undef, 'C: Non-existant driver is undef' ); +is( _CLASSISA('D', 'A'), 'D', 'D: Broken driver is undef' ); +is( _CLASSISA('E', 'A'), undef, 'E: Not a driver returns undef' ); +is( _CLASSISA('F', 'A'), 'F', 'F: Faked isa returns ok' ); + +# Repeat for subclasses +is( _SUBCLASS('A', 'A'), undef, 'A: Driver base class is undef' ); +is( _SUBCLASS('My_B', 'A'), 'My_B', 'B: Good driver returns ok' ); +is( _SUBCLASS('My_B', 'H'), undef, 'B: Good driver return undef for incorrect base' ); +is( _SUBCLASS('C', 'A'), undef, 'C: Non-existant driver is undef' ); +is( _SUBCLASS('D', 'A'), 'D', 'D: Broken driver is undef' ); +is( _SUBCLASS('E', 'A'), undef, 'E: Not a driver returns undef' ); +is( _SUBCLASS('F', 'A'), 'F', 'F: Faked isa returns ok' ); + +SKIP: { + use_ok('Params::Util', qw(_CLASSDOES)); + + skip "DOES tests do not make sense on perls before 5.10", 4 + unless $] >= 5.010; + + is( _CLASSDOES('A', 'A'), 'A', 'A: DOES A' ); + is( _CLASSDOES('My_B', 'A'), 'My_B', 'My_B: DOES A' ); + is( _CLASSDOES('E', 'A'), undef, 'E: DOES not A' ); + is( _CLASSDOES('F', 'A'), 'F', 'F: DOES A' ); +} |