use strict;
use Config;
# keep stdout and stderr in order on Win32
BEGIN {
$|=1;
my $oldfh = select(STDERR); $| = 1; select($oldfh);
}
# If running under threads, Test::More must load *after* threads.pm
# so load Test::More only if needed to bail out or only after loading
# threads.pm
BEGIN {
# don't run without threads configured
if ( ! $Config{useithreads} ) {
require Test::More;
Test::More::plan( skip_all =>
"perl ithreads not available" );
}
# don't run for Perl prior to 5.8 (with CLONE) (even if
# threads *are* configured)
if( $] < 5.008005 ) {
require Test::More;
Test::More::plan( skip_all =>
"thread support requires perl 5.8.5" );
}
# don't run without Scalar::Util::weaken()
eval "use Scalar::Util 'weaken'";
if( $@ =~ /\AWeak references are not implemented/ ) {
require Test::More;
Test::More::plan( skip_all =>
"Scalar::Util::weaken() is required for thread-safety" );
}
# don't run this at all under Devel::Cover
if ( $ENV{HARNESS_PERL_SWITCHES} &&
$ENV{HARNESS_PERL_SWITCHES} =~ /Devel::Cover/ ) {
require Test::More;
Test::More::plan( skip_all =>
"Devel::Cover not compatible with threads" );
}
}
use threads;
use Test::More tests => 10;
#--------------------------------------------------------------------------#
my $class = "t::Object::Animal";
my $subclass = "t::Object::Animal::Antelope";
my ($o, $p);
#--------------------------------------------------------------------------#
require_ok( $class );
require_ok( $subclass );
ok( ($o = $class->new()) && $o->isa($class),
"Creating a $class object"
);
ok( ($p = $subclass->new()) && $p->isa($subclass),
"Creating a $subclass object"
);
is( $o->name( "Larry" ), "Larry",
"Setting a name for the superclass object in the parent"
);
is( $p->name( "Harry" ), "Harry",
"Setting a name for the subclass object in the parent"
);
is( $p->color( "brown" ), "brown",
"Setting a color for the subclass object in the parent"
);
my $thr = threads->new(
sub {
is( $o->name, "Larry", "got right superclass object name in thread");
is( $p->name, "Harry", "got right subclass object name in thread");
is( $p->color, "brown", "got right subclass object name in thread");
}
);
SKIP: {
skip "Couldn't create a thread", 3
unless defined $thr;
$thr->join;
}