The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
# 08_loadMethods.t
#
# Tests the method scoping

use Test::More tests => 20;

use strict;
use warnings;

package Foo;

use vars qw(@ISA @_methods);
use Class::EHierarchy qw(:all);

@ISA = qw(Class::EHierarchy);
@_methods = (
    [ CEH_PRIV,  qw(mpriv) ],
    [ CEH_RESTR, qw(mrestr) ],
    [ CEH_PUB,   qw(mpub) ],
    );

sub _initialize ($@) {
    my $self = shift;
    my @args = @_;

    return 1;
}

sub mpriv {
    my $self = shift;

    return 2;
}

sub mrestr {
    my $self = shift;

    return 4;
}

sub mpub {
    my $self = shift;

    return 8;
}

sub callpriv {
    my $self = shift;
    my $obj  = shift;

    return $obj->mpriv;
}

sub callrestr {
    my $self = shift;
    my $obj  = shift;

    return $obj->mrestr;
}

1;

package Bar;

use vars qw(@ISA @_methods);
use Class::EHierarchy qw(:all);

@ISA = qw(Foo);
@_methods = (
    [ CEH_PRIV,  qw(mpriv) ],
    [ CEH_RESTR, qw(mrestr) ],
    [ CEH_PUB,   qw(mpub) ]
    );

sub _initialize ($@) {
    my $self = shift;
    my @args = @_;

    return 1;
}

sub mpriv ($) {
    my $self = shift;

    return 4;
}

sub mrestr {
    my $self = shift;

    return 8;
}

sub mpub {
    my $self = shift;

    return 16;
}

sub callpriv {
    my $self = shift;
    my $obj  = shift;

    return $obj->mpriv;
}

sub callrestr {
    my $self = shift;
    my $obj  = shift;

    return $obj->mrestr;
}

1;

package main;

my $class1a = new Foo;
my $class1b = new Foo;
my $class2a = new Bar;
my $class2b = new Bar;

my $rv;

# Test subclass instantiation
ok( defined $class1a,                   'Created object for class Foo 1' );
ok( defined $class1b,                   'Created object for class Foo 2' );
ok( $class1a->isa('Foo'),               'Verify class Foo 1' );
ok( $class1a->isa('Class::EHierarchy'), 'Verify class Foo inheritance 1' );

ok( defined $class2a,                   'Created object for class Bar 1' );
ok( defined $class2b,                   'Created object for class Bar 2' );
ok( $class2a->isa('Bar'),               'Verify class Bar 1' );
ok( $class2a->isa('Class::EHierarchy'), 'Verify class Bar inheritance 1' );
ok( $class2a->isa('Foo'),               'Verify class Bar inheritance 2' );

# Private method tests
#
# Call from same class should succeed
is( $class1a->callpriv($class1b), 2, 'Foo calling Foo Private Method 1' );
is( $class2a->callpriv($class2b), 4, 'Bar calling Bar Private Method 1' );

# Call from different class shoud fail
$rv = eval '$class2a->callpriv($class1a); 1;';
ok( !$rv, 'Bar calling Foo Private Method 1' );
$rv = eval '$class1a->callpriv($class2a); 1;';
ok( !$rv, 'Foo calling Bar Private Method 1' );

# Restricted method tests
#
# Call from same class should succeed
is( $class1a->callrestr($class1b), 4, 'Foo calling Foo Restricted Method 1' );
is( $class2a->callrestr($class2b), 8, 'Bar calling Bar Restricted Method 1' );

# Call from subclass should succeed
is( $class2a->callrestr($class1a), 4, 'Bar calling Foo Restricted Method 1' );

# Call from non-subclass should fail
$rv = eval '$class1a->callrestr($class2a); 1;';
ok( !$rv, 'Foo calling Bar Restricted Method 1' );
$rv = eval '$class1a->mrestr(); 1;';
ok( !$rv, 'Main calling Foo Restricted Method 1' );

# Public method tests
#
# Calls should succeed
is( $class1a->mpub, 8,  'Foo Public Method 1' );
is( $class2a->mpub, 16, 'Bar Public Method 1' );

# end 08_loadMethods.t