view _test/Test/Object/Common.pm @ 381:ced5937ff21a

Custom getters/setters support method names in theirs definitions Initial support for localizable labels in DOM schemas
author cin
date Wed, 22 Jan 2014 16:56:10 +0400
parents 76515373dac0
children
line wrap: on
line source

package Test::Object::Common;
use strict;
use warnings;

use IMPL::Test qw(test failed cmparray assert);
use IMPL::declare {
	base => [
		'IMPL::Test::Unit' => '@_' 
	]
};

{
    package Foo;
    use parent qw(IMPL::Object);
    
    sub CTOR {
        my ($this,$refarg) = @_;
        $$refarg = 1;
    }
    
    package Bar;
    use parent qw(-norequire Foo);
    
    __PACKAGE__->PassThroughArgs;
    
    sub CTOR {
        my ($this,$ref,$array) = @_;
        
        push @$array,__PACKAGE__;
    }
    
    package Baz;
    use parent qw(-norequire Bar);
    
    our %CTOR = (
        Bar => sub {
            my $t;
            (\$t,$_[0]);
        }
    );
    
    sub CTOR {
        my ($this,$array) = @_;
        push @$array,__PACKAGE__;
    }
    
    package Zoo;
    use parent qw(-norequire Bar);
    
    __PACKAGE__->PassThroughArgs;
    
    sub CTOR {
       my ($this,$ref,$array) = @_;
       
       push @$array,__PACKAGE__;
    };
    
    package Complex;
    use parent qw(-norequire Baz Zoo);
    
    our %CTOR = (
        Baz => sub { @_ },
        Zoo => sub {
            my $t;
            (\$t,$_[0]);
        }
    );
    
}

test Creation => sub {
    my $flag = 0;
    
    my $obj = new Foo(\$flag);
    
    die new IMPL::Test::FailException("Object is undef") unless $obj;
    die new IMPL::Test::FailException("Contructor doesn't run") unless $obj;
};

test SimpleInheritance => sub {
    my $sequence = [];
    my $flag = 0;
    my $obj = new Bar(\$flag,$sequence);
    
    failed "Object is undef" unless $obj;
    failed "Base class constructor isn't called" unless $flag;
    failed "Class constructor isn't called" unless @$sequence;
};

test SimpleInheritance2 => sub {
    my $sequence = [];
    my $expected = [qw(Bar Baz)];
    my $obj = new Baz($sequence);
    
    failed "Object is undef" unless $obj;
    failed "Wrong constructor sequence","expected: " . join(', ',@$expected),"actual: ".join(', ',@$sequence) unless cmparray $sequence,$expected;
};

test MultipleInheritance => sub {
    my $sequence = [];
    my $expected = [qw(Bar Baz Bar Zoo)];
    my $obj = new Complex($sequence);
    
    failed "Object is undef" unless $obj;
    failed "Wrong constructor sequence","expected: " . join(', ',@$expected),"actual: ".join(', ',@$sequence) unless cmparray $sequence,$expected;
};

test CustomGetterSetter => sub {
	my $obj = Test::Object::Common::Bar->new();
	
	assert($obj->custom eq 'default');
	$obj->custom('new_value');
	assert($obj->custom eq 'new_value');
};

package Test::Object::Common::Bar;
use IMPL::Const qw(:prop);
use IMPL::declare {
	base => [
		'IMPL::Object' => undef
	],
	props => [
		custom => {
			get => '_getCustom',
			set => '_setCustom',
			direct => 1
		}
	]
};

sub _getCustom {
	shift->{$custom} || 'default';
}

sub _setCustom {
	my ($this,$value) = @_;
	$this->{$custom} = $value;
}

1;