package Variant1::RootClass;

our $VERSION = 1.00;

use strict;
use warnings;
use Carp;
use vars qw( $AUTOLOAD );

{
    # Encapsulated class data

    my %_attr_data = #        DEFAULT          ACCESSIBILITY
        ( '_root_entry1' => [ undef     ,        'read/write'],
          '_root_entry2' => [ undef     ,        'read'] );

    # Class methods to operate on encapsulated class data


    # Is a specified object attribute accessible in a given mode
    sub _accessible
    {
        my ($self, $attr, $mode) = @_;
        $_attr_data{$attr}[1] =~ /$mode/;
    }

    # Classwide default value for a specified object attribute
    sub _default_for
    {
        my ($self, $attr) = @_;
        $_attr_data{$attr}[0];
    }

    # List of names of all specified object attributes
    sub _standard_keys
    {
        keys %_attr_data;
    }  
}

# Constructor may be called as a class method or object method

sub new
{
    my ($caller, %arg) = @_;
    my $caller_is_obj = ref($caller);
    my $class = $caller_is_obj || $caller;
    my $self = bless {}, $ class;

    foreach my $attr_name ( $self->_standard_keys() )
    {
        my ($arg_name) = ($attr_name =~ /^_(.*)/);

        # take value from given argument if available
        if( exists $arg{$arg_name} )
        {
            $self->{$attr_name} = $arg{$arg_name};
        }

        # take value from object if caller is an object
        elsif( $caller_is_obj )
        {
            $self->{$attr_name} = $caller->{$attr_name};
        }

        # take default value
        else
        {
            $self->{$attr_name} = $self->_default_for($attr_name);
        }           
    }

    return $self;
}

sub DESTROY
{
    # nothing to do here
}

# Implement get_... and set_... methods
sub AUTOLOAD
{
    no strict "refs";
    my ($self, $newval) = @_;

    # Was it a get_... method?
    if( $AUTOLOAD =~ /.*::get(_\w+)/ && $self->_accessible($1, 'read') )
    {
        my $attr_name = $1;
        *{$AUTOLOAD} = sub { return $_[0]->{$attr_name} };
        return $self->{$attr_name};
    }

    # Was it a set_... method?
    if( $AUTOLOAD =~ /.*::set(_\w+)/ && $self->_accessible($1, 'write') )
    {
        my $attr_name = $1;
        *{$AUTOLOAD} = sub { $_[0]->{$attr_name} = $_[1]; return; };
        $self->{$1} = $newval;
        return;        
    }

    # Must have a mistake then ...
    croak "No such method: $AUTOLOAD";
    
}

1;

##</code><code>##

use Variant1::RootClass;

package Variant1::DerivedClass;
our @ISA = qw( Variant1::RootClass );
our $VERSION = 1.00;

use strict;
use warnings;

{
    # Encapsulated class data

    my %_attr_data = #        DEFAULT          ACCESSIBILITY
        ( '_derived_entry1' => [ undef     ,        'read'],
          '_derived_entry2' => [ undef     ,        'read'],
          '_derived_entry3' => [ undef     ,        'read/write']);

    # Class methods to operate on encapsulated class data
    

    # Is a specified object attribute accessible in a given mode
    sub _accessible
    {
        my ($self, $attr, $mode) = @_;
        return $_attr_data{$attr}[1] =~ /$mode/ if exists $_attr_data{$attr};
        return $self->SUPER::_accessible($attr,$mode);
    }

    # Classwide default value for a specified object attribute
    sub _default_for
    {
        my ($self, $attr) = @_;
        return $_attr_data{$attr}[0] if exists $_attr_data{$attr};
        return $self->SUPER::_default_for($attr);
    }

    # List of names of all specified object attributes
    sub _standard_keys
    {
        my ($self) = @_;
        (keys %_attr_data, $self->SUPER::_standard_keys());
    }  
}

1;

##</code><code>##

use Variant1::DerivedClass;

package Variant1::DerivedDerivedClass;
our @ISA = qw( Variant1::DerivedClass );
our $VERSION = 1.00;

use strict;
use warnings;

{
    # Encapsulated class data

    my %_attr_data = #                    DEFAULT          ACCESSIBILITY
        ( '_derived_derived_entry1' => [ undef     ,        'read'],
          '_derived_derived_entry2' => [ undef     ,        'read'],
          '_derived_derived_entry3' => [ undef     ,        'read/write']);

    # Class methods to operate on encapsulated class data
    

    # Is a specified object attribute accessible in a given mode
    sub _accessible
    {
        my ($self, $attr, $mode) = @_;
        return $_attr_data{$attr}[1] =~ /$mode/ if exists $_attr_data{$attr};
        return $self->SUPER::_accessible($attr,$mode);
    }

    # Classwide default value for a specified object attribute
    sub _default_for
    {
        my ($self, $attr) = @_;
        return $_attr_data{$attr}[0] if exists $_attr_data{$attr};
        return $self->SUPER::_default_for($attr);
    }

    # List of names of all specified object attributes
    sub _standard_keys
    {
        my ($self) = @_;
        (keys %_attr_data, $self->SUPER::_standard_keys());
    }  
}

1;

##</code><code>##

package Variant2::RootClass;

our $VERSION = 1.00;

use strict;
use warnings;
use Carp;
use vars qw( $AUTOLOAD );

{
    # Encapsulated class data

    my %_attr_data = #        DEFAULT          ACCESSIBILITY
        ( '_root_entry1' => [ undef     ,        'read/write'],
          '_root_entry2' => [ undef     ,        'read'] );

    # Class methods to operate on encapsulated class data


    # get attribute class data
    sub _get_attr_data
    {
        %_attr_data;
    }

    # Is a specified object attribute accessible in a given mode
    sub _accessible
    {
        my ($self, $attr, $mode) = @_;
        my %attr_data = $self->_get_attr_data();        
        $attr_data{$attr}[1] =~ /$mode/;
    }

    # Classwide default value for a specified object attribute
    sub _default_for
    {
        my ($self, $attr) = @_;
        my %attr_data = $self->_get_attr_data();
        $attr_data{$attr}[0];
    }

    # List of names of all specified object attributes
    sub _standard_keys
    {
        my ($self) = @_;
        my %attr_data = $self->_get_attr_data();
        keys %attr_data;
    }  
}

# Constructor may be called as a class method or object method

sub new
{
    my ($caller, %arg) = @_;
    my $caller_is_obj = ref($caller);
    my $class = $caller_is_obj || $caller;
    my $self = bless {}, $ class;

    foreach my $attr_name ( $self->_standard_keys() )
    {
        my ($arg_name) = ($attr_name =~ /^_(.*)/);

        # take value from given argument if available
        if( exists $arg{$arg_name} )
        {
            $self->{$attr_name} = $arg{$arg_name};
        }

        # take value from object if caller is an object
        elsif( $caller_is_obj )
        {
            $self->{$attr_name} = $caller->{$attr_name};
        }

        # take default value
        else
        {
            $self->{$attr_name} = $self->_default_for($attr_name);
        }           
    }

    return $self;
}

sub DESTROY
{
    # nothing to do here
}

# Implement get_... and set_... methods
sub AUTOLOAD
{
    no strict "refs";
    my ($self, $newval) = @_;

    # Was it a get_... method?
    if( $AUTOLOAD =~ /.*::get(_\w+)/ && $self->_accessible($1, 'read') )
    {
        my $attr_name = $1;
        *{$AUTOLOAD} = sub { return $_[0]->{$attr_name} };
        return $self->{$attr_name};
    }

    # Was it a set_... method?
    if( $AUTOLOAD =~ /.*::set(_\w+)/ && $self->_accessible($1, 'write') )
    {
        my $attr_name = $1;
        *{$AUTOLOAD} = sub { $_[0]->{$attr_name} = $_[1]; return; };
        $self->{$1} = $newval;
        return;        
    }

    # Must have a mistake then ...
    croak "No such method: $AUTOLOAD";
    
}

1;

##</code><code>##

use Variant2::RootClass;

package Variant2::DerivedClass;
our @ISA = qw( Variant2::RootClass );
our $VERSION = 1.00;

use strict;
use warnings;

{
    # Encapsulated class data

    my %_attr_data = #        DEFAULT          ACCESSIBILITY
        ( '_derived_entry1' => [ undef     ,        'read'],
          '_derived_entry2' => [ undef     ,        'read'],
          '_derived_entry3' => [ undef     ,        'read/write']);

    # Class methods to operate on encapsulated class data

    # get attribute class data of this class and its base class
    sub _get_attr_data
    {
        (%_attr_data, $_[0]->SUPER::_get_attr_data());
    }
}

1;

##</code><code>##

use Variant2::DerivedClass;

package Variant2::DerivedDerivedClass;
our @ISA = qw( Variant2::DerivedClass );
our $VERSION = 1.00;

use strict;
use warnings;

{
    # Encapsulated class data

    my %_attr_data = #                    DEFAULT          ACCESSIBILITY
        ( '_derived_derived_entry1' => [ undef     ,        'read'],
          '_derived_derived_entry2' => [ undef     ,        'read'],
          '_derived_derived_entry3' => [ undef     ,        'read/write']);

    # Class methods to operate on encapsulated class data
    
    # get attribute class data of this class and its base class
    sub _get_attr_data
    {
        (%_attr_data, $_[0]->SUPER::_get_attr_data());
    }
}

1;

##</code><code>##

#!/usr/bin/perl

use strict;
use warnings;

use Data::Dumper;
use Variant1::DerivedDerivedClass;
use Variant2::DerivedDerivedClass;

# VARIANT 1
my $obj1 = Variant1::DerivedDerivedClass->new('root_entry1' => 1,
                                             'root_entry2' => 2,
                                             'derived_entry1' => 3,
                                             'derived_entry2' => 4,
                                             'derived_entry3' => 5,
                                             'derived_derived_entry1' => 6,
                                             'derived_derived_entry2' => 7,
                                             'derived_derived_entry3' => 8 );

print $obj1->set_derived_entry3(27);
print Dumper $obj1;

# VARIANT 2
my $obj2 = Variant2::DerivedDerivedClass->new('root_entry1' => 1,
                                             'root_entry2' => 2,
                                             'derived_entry1' => 3,
                                             'derived_entry2' => 4,
                                             'derived_entry3' => 5,
                                             'derived_derived_entry1' => 6,
                                             'derived_derived_entry2' => 7,
                                             'derived_derived_entry3' => 8 );

print $obj2->set_derived_entry3(27);
print Dumper $obj2;