#!/usr/bin/env perl
use strict;
use warnings;
use Test::More;
use UR;
use MRO::Compat;
setup_test_env();
test_namespace_valid_values_mro();
test_namespace_gets_default_mro();
test_gryphon_object_methods_follow_dfs_mro();
test_gryphon_inheritance_follows_dfs_mro();
test_class_property_follows_dfs_mro();
test_package_sub_follows_dfs_mro();
if ($^V lt 5.9.5) {
my $namespace = C3Animal->get();
is($namespace->method_resolution_order, 'dfs', 'MRO reverted to DFS on a C3 namespace if Perl < 5.9.5');
note('Skipping C3 tests because Perl < 5.9.5.');
} else {
test_gryphon_object_methods_follow_c3_mro();
test_gryphon_inheritance_follows_c3_mro();
test_class_property_follows_c3_mro();
test_package_sub_follows_c3_mro();
}
done_testing();
sub test_namespace_valid_values_mro {
my $namespace = Animal->get();
my $property = $namespace->__meta__->property('method_resolution_order');
if ($^V lt 5.9.5) {
is_deeply($property->valid_values, ['dfs'], 'valid MRO for Perl < 5.9.5 is only DFS');
} else {
is_deeply($property->valid_values, ['dfs', 'c3'], 'valid MRO for Perl >= 5.9.5 is DFS and C3');
}
}
sub test_namespace_gets_default_mro {
my $animal_namespace = Animal->get();
isa_ok($animal_namespace, 'UR::Namespace', 'got Animal namespace');
# This is meant to check that the namespace has the default value of method_resolution_order
# populated on get unlike non-singleton objects which are only populated on create.
ok($animal_namespace->can('method_resolution_order'), 'namespace can method_resolution_order') || return;
ok($animal_namespace->method_resolution_order, 'namespace has a method_resolution_order');
}
#######################
# DFS Based Namespace #
#######################
sub test_gryphon_object_methods_follow_dfs_mro {
my $animal = DfsAnimal::Animal->create();
my $lion = DfsAnimal::Lion->create();
my $eagle = DfsAnimal::Eagle->create();
my $gryphon = DfsAnimal::Gryphon->create();
is($lion->foo, $animal->foo, "Lion's foo is the same as Animal's");
isnt($eagle->foo, $animal->foo, "Eagle's foo is not the same as Animal's");
is($gryphon->foo, $animal->foo, "Gryphon's foo is the same as Animal's");
}
sub test_gryphon_inheritance_follows_dfs_mro {
my $gryphon = DfsAnimal::Gryphon->create();
isa_ok($gryphon, 'DfsAnimal::Gryphon', '$gryphon isa DfsAnimal::Gryphon');
isa_ok($gryphon, 'DfsAnimal::Lion', '$gryphon isa DfsAnimal::Lion');
isa_ok($gryphon, 'DfsAnimal::Eagle', '$gryphon isa DfsAnimal::Eagle');
is(mro::get_mro('DfsAnimal::Gryphon'), 'dfs', "Gryphon's MRO is DFS");
my $i = 0;
my $mro_linear_isa = mro::get_linear_isa('DfsAnimal::Gryphon');
my %inheritance = map { $_ => $i++ } @$mro_linear_isa;
ok($inheritance{'DfsAnimal::Lion'} < $inheritance{'DfsAnimal::Eagle'}, 'Lion is higher precendence than Eagle');
ok($inheritance{'DfsAnimal::Eagle'} > $inheritance{'UR::Object'}, 'Eagle is lower precendence than UR::Object');
}
sub test_class_property_follows_dfs_mro {
# This is theoretically the same check as comparing $gryphon->foo to $eagle->foo
# However, it appears that property resolution is different than method resolution
# since property resolution is done by hand and is probably a breadth first search.
my $meta = UR::Object::Type->get(class_name => 'DfsAnimal::Gryphon');
my $foo_property_meta = $meta->property_meta_for_name('foo');
is($foo_property_meta->class_name, 'DfsAnimal::Eagle', "Gryphon is using Eagle's foo");
my $foo_property = $meta->property('foo');
is($foo_property->class_name, 'DfsAnimal::Eagle', "Gryphon is using Eagle's foo");
}
sub test_package_sub_follows_dfs_mro {
is(DfsAnimal::Animal->species(), 'Animal', "Make sure we installed species sub in Animal");
is(DfsAnimal::Eagle->species(), 'Eagle', "Make sure we installed species sub in Eagle");
is(DfsAnimal::Gryphon->species(), 'Animal', "Gryphon called Animal's species sub");
}
######################
# C3 Based Namespace #
######################
sub test_gryphon_object_methods_follow_c3_mro {
my $animal = C3Animal::Animal->create();
my $lion = C3Animal::Lion->create();
my $eagle = C3Animal::Eagle->create();
my $gryphon = C3Animal::Gryphon->create();
is($lion->foo, $animal->foo, "Lion's foo is the same as Animal's");
isnt($eagle->foo, $animal->foo, "Eagle's foo is not the same as Animal's");
is($gryphon->foo, $eagle->foo, "Gryphon's foo is the same as Eagle's");
}
sub test_gryphon_inheritance_follows_c3_mro {
my $gryphon = C3Animal::Gryphon->create();
isa_ok($gryphon, 'C3Animal::Gryphon', '$gryphon isa C3Animal::Gryphon');
isa_ok($gryphon, 'C3Animal::Lion', '$gryphon isa C3Animal::Lion');
isa_ok($gryphon, 'C3Animal::Eagle', '$gryphon isa C3Animal::Eagle');
is(mro::get_mro('C3Animal::Gryphon'), 'c3', "Gryphon's MRO is C3");
my $i = 0;
my $mro_linear_isa = mro::get_linear_isa('C3Animal::Gryphon');
my %inheritance = map { $_ => $i++ } @$mro_linear_isa;
ok($inheritance{'C3Animal::Lion'} < $inheritance{'C3Animal::Eagle'}, 'Lion is higher precendence than Eagle');
ok($inheritance{'C3Animal::Eagle'} < $inheritance{'UR::Object'}, 'Eagle is higher precendence than UR::Object');
}
sub test_class_property_follows_c3_mro {
# This is theoretically the same check as comparing $gryphon->foo to $eagle->foo
# However, it appears that property resolution is different than method resolution
# since property resolution is done by hand and is probably a breadth first search.
my $meta = UR::Object::Type->get(class_name => 'C3Animal::Gryphon');
my $foo_property_meta = $meta->property_meta_for_name('foo');
is($foo_property_meta->class_name, 'C3Animal::Eagle', "Gryphon is using Eagle's foo");
my $foo_property = $meta->property('foo');
is($foo_property->class_name, 'C3Animal::Eagle', "Gryphon is using Eagle's foo");
}
sub test_package_sub_follows_c3_mro {
is(C3Animal::Animal->species(), 'Animal', "Make sure we installed species sub in Animal");
is(C3Animal::Eagle->species(), 'Eagle', "Make sure we installed species sub in Eagle");
is(C3Animal::Gryphon->species(), 'Eagle', "Gryphon called Eagle's species sub");
}
sub setup_test_env {
no warnings 'once';
my $animal_namespace_type = UR::Object::Type->define(
class_name => 'Animal',
is => 'UR::Namespace',
);
isa_ok($animal_namespace_type, 'UR::Object::Type', 'defined Animal namespace');
#######################
# DFS Based Namespace #
#######################
my $dfs_animal_namespace_type = UR::Object::Type->define(
class_name => 'DfsAnimal',
is => 'UR::Namespace',
has => [
method_resolution_order => {
is => 'Text',
default_value => 'dfs',
},
],
);
isa_ok($dfs_animal_namespace_type, 'UR::Object::Type', 'defined DfsAnimal namespace');
my $dfs_animal_namespace = DfsAnimal->get();
isa_ok($dfs_animal_namespace, 'UR::Namespace', 'got DfsAnimal namespace');
is($dfs_animal_namespace->method_resolution_order, 'dfs', "DfsAnimal's MRO is DFS");
my $dfs_animal_type = UR::Object::Type->define(
class_name => 'DfsAnimal::Animal',
has => [
foo => {
is_constant => 1,
calculate => q(
return 'Animal';
),
},
],
);
isa_ok($dfs_animal_type, 'UR::Object::Type', 'defined Animal');
is($dfs_animal_type->namespace, 'DfsAnimal', 'DfsAnimal::Animal is in Animal namespace');
*DfsAnimal::Animal::species = sub { 'Animal' };
my $dfs_lion_type = UR::Object::Type->define(
class_name => 'DfsAnimal::Lion',
is => 'DfsAnimal::Animal',
);
isa_ok($dfs_lion_type, 'UR::Object::Type', 'defined DfsAnimal::Lion');
my $dfs_eagle_type = UR::Object::Type->define(
class_name => 'DfsAnimal::Eagle',
is => 'DfsAnimal::Animal',
has => [
foo => {
is_constant => 1,
calculate => q(
return 'Eagle';
),
},
],
);
isa_ok($dfs_eagle_type, 'UR::Object::Type', 'defined DfsAnimal::Eagle');
no warnings 'redefine';
*DfsAnimal::Eagle::species = sub { 'Eagle' };
use warnings 'redefine';
my $dfs_gryphon_type = UR::Object::Type->define(
class_name => 'DfsAnimal::Gryphon',
is => ['DfsAnimal::Lion', 'DfsAnimal::Eagle'],
);
isa_ok($dfs_gryphon_type, 'UR::Object::Type', 'defined DfsAnimal::Gryphon');
######################
# C3 Based Namespace #
######################
my $c3_animal_namespace_type = UR::Object::Type->define(
class_name => 'C3Animal',
is => 'UR::Namespace',
has => [
method_resolution_order => {
is => 'Text',
default_value => 'c3',
},
],
);
isa_ok($c3_animal_namespace_type, 'UR::Object::Type', 'defined C3Animal namespace');
my $c3_animal_namespace = C3Animal->get();
isa_ok($c3_animal_namespace, 'UR::Namespace', 'got C3Animal namespace');
is($c3_animal_namespace->method_resolution_order, 'c3', "C3Animal's MRO is C3");
my $c3_animal_type = UR::Object::Type->define(
class_name => 'C3Animal::Animal',
has => [
foo => {
is_constant => 1,
calculate => q(
return 'Animal';
),
},
],
);
isa_ok($c3_animal_type, 'UR::Object::Type', 'defined Animal');
is($c3_animal_type->namespace, 'C3Animal', 'C3Animal::Animal is in Animal namespace');
*C3Animal::Animal::species = sub { 'Animal' };
my $c3_lion_type = UR::Object::Type->define(
class_name => 'C3Animal::Lion',
is => 'C3Animal::Animal',
);
isa_ok($c3_lion_type, 'UR::Object::Type', 'defined C3Animal::Lion');
my $c3_eagle_type = UR::Object::Type->define(
class_name => 'C3Animal::Eagle',
is => 'C3Animal::Animal',
has => [
foo => {
is_constant => 1,
calculate => q(
return 'Eagle';
),
},
],
);
isa_ok($c3_eagle_type, 'UR::Object::Type', 'defined C3Animal::Eagle');
no warnings 'redefine';
*C3Animal::Eagle::species = sub { 'Eagle' };
use warnings 'redefine';
my $c3_gryphon_type = UR::Object::Type->define(
class_name => 'C3Animal::Gryphon',
is => ['C3Animal::Lion', 'C3Animal::Eagle'],
);
isa_ok($c3_gryphon_type, 'UR::Object::Type', 'defined C3Animal::Gryphon');
use warnings 'once';
}