comment on

I know that there are many systems like Moo, Moose, etc. to build classes. But at the moment I'm reading the old book "Object Oriented Perl" from Damian Conway. Although it is very old, it helps me great to understand Object oriented Perl.

In his book there is an example with a derived class. It is ok for me, but the derived classes have to inherit a lot. I show that to you in Variant 1.

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;
[download]

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;
[download]

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          ACCESSIBILI
+TY
        ( '_derived_derived_entry1' => [ undef     ,        'read'],
          '_derived_derived_entry2' => [ undef     ,        'read'],
          '_derived_derived_entry3' => [ undef     ,        'read/writ
+e']);

    # 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;
[download]

In this variant 1 the derived classes have to reimplement _accessible, _default_for and _standard_keys. But they can inherit the constructor new and the AUTOLOAD subroutines.

I now created a variant 2. It has the same behavior from outside the class. But here the derived classes only need to reimplement _get_attr_data. All other subroutines can be inherited.

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;
[download]

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;
[download]

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          ACCESSIBILI
+TY
        ( '_derived_derived_entry1' => [ undef     ,        'read'],
          '_derived_derived_entry2' => [ undef     ,        'read'],
          '_derived_derived_entry3' => [ undef     ,        'read/writ
+e']);

    # 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;
[download]

And here a test script to use these classes.

#!/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;
[download]

Would it be possible to even put the _get_attr_data only in the base class. In this way the derived classes would have to reimplement nothing. Everything could be derived.

If not. I'm not sure if I implemented the variant 2 in a good way. For my feeling I'm doing it in a bad way because I'm calling the _get_attr_data at so many places. Is there a better way to implement it?

Thanks a lot for your help.

2019-12-16 Athanasius added readmore tags.

In reply to Class attribute handling by Dirk80

Title:
Use: <p> text here (a paragraph) </p>
and: <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":

Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!

Titles consisting of a single word are discouraged, and in most cases are disallowed outright.

Read Where should I post X? if you're not absolutely sure you're posting in the right place.

Please read these before you post! —

How do I compose an effective node title?

How do I post a question effectively?

Markup in the Monastery

Posts may use any of the Perl Monks Approved HTML tags:
a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr

You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)

For: Use:

& &

< <

> >

[ [

] ]

Link using PerlMonks shortcuts! What shortcuts can I use for linking?

See Writeup Formatting Tips and other pages linked from there for more info.