The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use warnings;
use strict;

use File::Basename;
use lib File::Basename::dirname(__FILE__)."/../../../lib";
use lib File::Basename::dirname(__FILE__)."/../..";
use URT;
use URT::DataSource::SomeSQLite;

use Test::More tests => 102;

UR::Object::Type->define(
    class_name => 'Acme',
    is => ['UR::Namespace'],
);

note('Tests for subclassing by regular property');

our $calculate_called = 0;
UR::Object::Type->define(
    class_name => 'Acme::Employee',
    subclassify_by => 'subclass_name',
    is_abstract => 1,
    has => [
        name => { type => "String" },
        subclass_name => { type => 'String' },
    ],
);

UR::Object::Type->define(
    class_name => 'Acme::Employee::Worker',
    is => 'Acme::Employee',
);

UR::Object::Type->define(
    class_name => 'Acme::Employee::Boss',
    is => 'Acme::Employee',
);

my $e1 = eval { Acme::Employee->create(name => 'Bob') };
ok(! $e1, 'Unable to create an object from the abstract class without a subclass_name');
like($@, qr/Can't use undefined value as a subclass name/, 'The exception was correct');

$e1 = Acme::Employee->create(name => 'Bob', subclass_name => 'Acme::Employee::Worker');
ok($e1, 'Created an object from the base class and specified subclass_name');
isa_ok($e1, 'Acme::Employee::Worker');
is($e1->name, 'Bob', 'Name is correct');
is($e1->subclass_name, 'Acme::Employee::Worker', 'subclass_name is correct');

$e1 = Acme::Employee::Worker->create(name => 'Bob2');
ok($e1, 'Created an object from a subclass without subclass_name');
isa_ok($e1, 'Acme::Employee::Worker');
is($e1->name, 'Bob2', 'Name is correct');
is($e1->subclass_name, 'Acme::Employee::Worker', 'subclass_name is correct');

$e1 = Acme::Employee->create(name => 'Fred', subclass_name => 'Acme::Employee::Boss');
ok($e1, 'Created an object from the base class and specified subclass_name');
isa_ok($e1, 'Acme::Employee::Boss');
is($e1->name, 'Fred', 'Name is correct');
is($e1->subclass_name, 'Acme::Employee::Boss', 'subclass_name is correct');

$e1 = Acme::Employee::Boss->create(name => 'Fred2');
ok($e1, 'Created an object from a subclass without subclass_name');
isa_ok($e1, 'Acme::Employee::Boss');
is($e1->name, 'Fred2', 'Name is correct');
is($e1->subclass_name, 'Acme::Employee::Boss', 'subclass_name is correct');

$e1 = Acme::Employee::Boss->create(name => 'Fred3', subclass_name => 'Acme::Employee::Boss');
ok($e1, 'Created an object from a subclass and specified the same subclass_name');
isa_ok($e1, 'Acme::Employee::Boss');
is($e1->name, 'Fred3', 'Name is correct');
is($e1->subclass_name, 'Acme::Employee::Boss', 'subclass_name is correct');



$e1 = eval { Acme::Employee::Worker->create(name => 'Joe', subclass_name => 'Acme::Employee') };
ok(! $e1, 'Creating an object from a subclass with the base class as subclass_name did not work');
like($@,
     qr/Value for subclassifying param 'subclass_name' \(Acme::Employee\) does not match the class it was called on \(Acme::Employee::Worker\)/,
     'Exception was correct');

$e1 = eval { Acme::Employee::Worker->create(name => 'Joe', subclass_name => 'Acme::Employee::Boss') };
ok(! $e1, 'Creating an object from a subclass with another subclass as subclass_name did not work');
like($@,
     qr/Value for subclassifying param 'subclass_name' \(Acme::Employee::Boss\) does not match the class it was called on \(Acme::Employee::Worker\)/,
     'Exception was correct');

$e1 = eval { Acme::Employee::Boss->create(name => 'Joe', subclass_name => 'Acme::Employee::Worker') };
ok(! $e1, 'Creating an object from a subclass with another subclass as subclass_name did not work');
like($@,
     qr/Value for subclassifying param 'subclass_name' \(Acme::Employee::Worker\) does not match the class it was called on \(Acme::Employee::Boss\)/,
     'Exception was correct');

$e1 = eval { Acme::Employee->create(name => 'Mike', subclass_name => 'Acme::Employee::NonExistent') };
ok(! $e1, 'Creating an object from the base class and gave invalid subclass_name did not work');
like($@,
     qr/Class Acme::Employee::NonExistent is not a subclass of Acme::Employee/,
     'Exception was correct');



note('Tests for default value subclassing');

UR::Object::Type->define(
    class_name => 'Acme::Tool',
    is_abstract => 1,
    subclassify_by => 'subclass_name',
    has => [
        sku => { is => 'Number'},
        subclass_name => { is => 'String', default_value => 'Acme::Tool::Generic' },
    ],
);

UR::Object::Type->define(
    class_name => 'Acme::Tool::Hammer',
    is => 'Acme::Tool',
);

UR::Object::Type->define(
    class_name => 'Acme::Tool::Generic',
    is => 'Acme::Tool',
);

my $t = eval { Acme::Tool->create(sku => 123) };
ok($t, 'Created an Acme::Tool without subclass_name');
ok(! $@, 'No exception during create');
is($t->subclass_name, 'Acme::Tool::Generic', 'subclass_name took the default value');
isa_ok($t, 'Acme::Tool::Generic');
isa_ok($t, 'Acme::Tool');

$t = eval { Acme::Tool->create(sku => 234, subclass_name => 'Acme::Tool::Generic') };
ok($t, 'Created an Acme::Tool with subclass_name');
ok(! $@, 'No exception during create');
is($t->subclass_name, 'Acme::Tool::Generic', 'subclass_name has the correct value');
isa_ok($t, 'Acme::Tool::Generic');
isa_ok($t, 'Acme::Tool');

$t = eval { Acme::Tool::Generic->create(sku => 456) };
ok($t, 'Created an Acme::Tool::Generic without subclass_name');
ok(! $@, 'No exception during create');
is($t->subclass_name, 'Acme::Tool::Generic', 'subclass_name has the correct value');
isa_ok($t, 'Acme::Tool::Generic');
isa_ok($t, 'Acme::Tool');

$t = eval { Acme::Tool::Generic->create(sku => 456, subclass_name => 'Acme::Tool::Generic') };
ok($t, 'Created an Acme::Tool::Generic with subclass_name');
ok(! $@, 'No exception during create');
is($t->subclass_name, 'Acme::Tool::Generic', 'subclass_name has the correct value');
isa_ok($t, 'Acme::Tool::Generic');
isa_ok($t, 'Acme::Tool');

$t = eval { Acme::Tool::Generic->create(sku => 567, subclass_name => 'Acme::Tool::Broken') };
ok(! $t, 'Did not create an Acme::Tool::Generic with a non-matching subclass_name');
like($@,
     qr/Value for subclassifying param 'subclass_name' \(Acme::Tool::Broken\) does not match the class it was called on \(Acme::Tool::Generic\)/,
     'Exception was correct');

$t = eval { Acme::Tool->create(sku => 678, subclass_name => 'Acme::Tool::Hammer') };
ok($t, 'Created an Acme::Tool with subclass_name Acme::Tool::Hammer');
ok(! $@, 'No exception during create');
is($t->subclass_name, 'Acme::Tool::Hammer', 'subclass_name has the correct value');
isa_ok($t, 'Acme::Tool::Hammer');
isa_ok($t, 'Acme::Tool');

$t = eval { Acme::Tool::Hammer->create(sku => 789, subclass_name => 'Acme::Tool::Hammer') };
ok($t, 'Created an Acme::Tool::Hammer with subclass_name Acme::Tool::Hammer');
ok(! $@, 'No exception during create');
is($t->subclass_name, 'Acme::Tool::Hammer', 'subclass_name has the correct value');
isa_ok($t, 'Acme::Tool::Hammer');
isa_ok($t, 'Acme::Tool');

$t = eval { Acme::Tool::Hammer->create(sku => 678, subclass_name => 'Acme::Tool::Generic') };
ok(! $t, 'Did not create an Acme::Tool::Hammer with a non-matching subclass_name');
like($@,
     qr/Value for subclassifying param 'subclass_name' \(Acme::Tool::Generic\) does not match the class it was called on \(Acme::Tool::Hammer\)/,
     'Exception was correct');


note('Tests for indirect property subclassing');
UR::Object::Type->define(
    class_name => 'Acme::Rank',
    has => [
        name => { is => 'String' },
        soldier_subclass => { is_calculated => 1,
            calculate => q( return 'Acme::Soldier::'.ucfirst($self->name) )
        },
    ]
);

UR::Object::Type->define(
    class_name => 'Acme::Soldier',
    is_abstract => 1,
    subclassify_by => 'subclass_name',
    has => [
        name => { is => 'String' },
        rank => { is => 'Acme::Rank', id_by => 'rank_id' },
        subclass_name => { via => 'rank', to => 'soldier_subclass' },
    ],
);

UR::Object::Type->define(
    class_name => 'Acme::Soldier::Private',
    is => 'Acme::Soldier',
);

UR::Object::Type->define(
    class_name => 'Acme::Soldier::General',
    is => 'Acme::Soldier',
);

my $private = Acme::Rank->create(name => 'Private');
my $general = Acme::Rank->create(name => 'General');

is($private->soldier_subclass, 'Acme::Soldier::Private', 'Private Rank returns correct soldier subclass');
is($general->soldier_subclass, 'Acme::Soldier::General', 'General Rank returns correct soldier subclass');

my $s = eval { Acme::Soldier->create(name => 'Pyle') };
ok(!$s, 'Unable to create an object from the abstract class without a subclass_name');
like($@, qr/Infering a value for property 'subclass_name' via rule.*returned multiple values/, 'Exception is correct');

$s = eval { Acme::Soldier->create(name => 'Pyle', rank => $private) };
ok($s, 'Created object from abstract parent, subclassed via an indirect object property');
is($s->subclass_name, 'Acme::Soldier::Private', 'subclass_name is correct');
isa_ok($s, 'Acme::Soldier::Private');

$s = eval { Acme::Soldier->create(name => 'Pyle', rank_id => $private->id) };
ok($s, 'Created object from abstract parent, subclassed via an indirect object ID');
is($s->subclass_name, 'Acme::Soldier::Private', 'subclass_name is correct');
isa_ok($s, 'Acme::Soldier::Private');

$s = Acme::Soldier->create(name => 'Pyle', subclass_name => 'Acme::Soldier::Private');
ok($s, 'Created object from abstract parent with subclass_name');
isa_ok($s, 'Acme::Soldier::Private');
is($s->rank, $private, 'Rank object was filled in properly');

$s = Acme::Soldier::Private->create(name => 'Beetle');
ok($s, 'Created object from child class');
isa_ok($s, 'Acme::Soldier::Private');
is($s->rank_id, $private->id, 'Its rank_id points to the Private Rank object');

$s = eval { Acme::Soldier::Private->create(name => 'Patton', rank => $general) };
ok(! $s, 'Unable to create an object from a child class when its rank indicates a different subclass');
like($@, qr/Conflicting values for property 'rank_id'/, 'Exception is correct');


note('Tests for calculated subclassing');

# First, setup a table we'll use in the next section of tests...
my $dbh = URT::DataSource::SomeSQLite->get_default_handle;
$dbh->do(q(create table vehicle (vehicle_id integer NOT NULL PRIMARY KEY, color varchar NOT NULL, wheels integer NOT NULL)));

$calculate_called = 0;
UR::Object::Type->define(
    class_name => 'Acme::Vehicle',
    is_abstract => 1,
    subclassify_by => 'subclass_name',
    id_by => 'vehicle_id',
    has => [
        color => { is => 'String' },
        wheels => { is => 'Integer' },
        subclass_name => { calculate_from => ['wheels'],
                           calculate => sub { my $wheels = shift;
                                              $calculate_called = 1;
                                              no warnings 'uninitialized';
                                              if (! defined $wheels) {
                                                  return;
                                              } elsif ($wheels == 2) {
                                                  return 'Acme::Motorcycle';
                                              } elsif ($wheels == 4) {
                                                  return 'Acme::Car';
                                              } elsif ($wheels == 0) {
                                                  return 'Acme::Sled';
                                              } else {
                                                 die "Can't create a vehicle with $wheels wheels";
                                              }
                                        },
                             },
    ],
    data_source => 'URT::DataSource::SomeSQLite',
    table_name => 'vehicle',
);

UR::Object::Type->define(
    class_name => 'Acme::Motorcycle',
    is => 'Acme::Vehicle',
);

UR::Object::Type->define(
    class_name => 'Acme::Car',
    is => 'Acme::Vehicle',
);

UR::Object::Type->define(
    class_name => 'Acme::Sled',
    is => 'Acme::Vehicle',
);

$calculate_called = 0;
my $v = eval { Acme::Vehicle->create(color => 'blue') };
ok(! $v, 'Unable to create an object from the abstract class without a subclass_name');
like($@, qr/Class Acme::Vehicle subclassify_by calculation property 'subclass_name' requires 'wheels' in the create\(\) params/, 'Exception was correct');
ok(! $calculate_called, 'The calculation function was called');

$calculate_called = 0;
$v = Acme::Vehicle->create(color => 'blue', wheels => 2, subclass_name => 'Acme::Motorcycle');
ok($v, 'Created an object from the base class by specifying subclass_name');
isa_ok($v, 'Acme::Motorcycle');
ok(! $calculate_called, 'The calculation function was not called');

$calculate_called = 0;
$v = Acme::Vehicle->create(color => 'green', wheels => 3, subclass_name => 'Acme::Motorcycle');
ok($v, 'Created another object from the base class');
isa_ok($v, 'Acme::Motorcycle');
ok(! $calculate_called, 'The calculation function was not called');

$calculate_called = 0;
$v = Acme::Vehicle->create(color => 'red', wheels => 4);
ok($v, 'Created an object from the base class by specifying wheels');
isa_ok($v, 'Acme::Car');
ok($calculate_called, 'The calculation function was called');
$calculate_called = 0;
is($v->subclass_name, 'Acme::Car', "It's subclass_name property is filled in");
ok(! $calculate_called, "Reading the subclass_name property didn't call the calculation sub");


note('Tests for loading with calculated subclassing');
$dbh->do(q(insert into vehicle(vehicle_id, color, wheels) values (99, 'blue', 2)));
$dbh->do(q(insert into vehicle(vehicle_id, color, wheels) values (98, 'green', 3)));
$dbh->do(q(insert into vehicle(vehicle_id, color, wheels) values (97, 'red', 4)));

$calculate_called = 0;
$v = Acme::Vehicle->get(99);
ok($v, 'Get an Acme::Vehicle out of the DB');
ok($calculate_called, 'The calculation function was called');
isa_ok($v, 'Acme::Motorcycle');


$calculate_called = 0;
$v = eval { Acme::Vehicle->get(98) };
ok(! $v, 'Acme::Vehicle with 3 wheels failed to load');
ok($calculate_called, 'The calculation function was called');
like($@, qr/Can't create a vehicle with 3 wheels/, 'Exception was correct');