Dirk80 has asked for the wisdom of the Perl Monks concerning the following question:

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.

Replies are listed 'Best First'.
Re: Class attribute handling
by choroba (Cardinal) on Dec 11, 2019 at 16:19 UTC
    I once implemented a similar hierarchy, but all the derived classes used the same %RootClass::attr_data. As I needed some statistics over existing objects in each class, I used ref of each object as the top level key in the hash, it also simplified inspecting the hash for human readers as the key indicated what data to expect in the deeper structure. Something like 
    #!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };

{   package My::Root;
    use Scalar::Util qw{ refaddr };

    our %attr;
    sub new {
        my ($class, $name) = @_;
        my $o;
        $attr{$class}{ refaddr(\$o) }{name} = $name;
        bless \ $o, $class;
    }
    sub name {
        my ($self) = @_;
        $attr{ ref $self }{ refaddr($self) }{name}
    }
    sub count {
        my ($class) = @_;
        return scalar keys %{ $attr{$class} }
    }
}

{   package My::Child;
    use parent -norequire => 'My::Root';
}

my $o1 = 'My::Root'->new('root1');
say $o1->name;

my $children = map 'My::Child'->new("child$_"), 1 .. 10;
say "Number of Root instances: ", 'My::Root'->count;
say "Number of Child instances: ", 'My::Child'->count;

    [download]

    map{substr$_->[0],$_->[1]||0,1}[\*||{},3],[[]],[ref qr-1,-,-1],[{}],[sub{}^*ARGV,3]
[reply]
[d/l]
[select]
Re: Class attribute handling
by tobyink (Canon) on Dec 11, 2019 at 17:14 UTC

    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.

    Short answer: yes.

    Long answer:

    use v5.12;
use strict;
use warnings;
use MRO::Compat;

package My::Base {
    my %_attr_data;
    my %_mro_cache;
    sub _get_attr_data {
        my $package = shift;
        my @parents = @{ $_mro_cache{$package} ||= mro::get_linear_isa
+($package) };
        my %return;
        for my $parent (@parents) {
            ref $_attr_data{$parent} or next;
            for my $attr (keys %{$_attr_data{$parent}}) {
                $return{$attr} ||= $_attr_data{$parent}{$attr};
            }
        }
        return %return;
    }
    sub _set_addr_data {
        my $package = shift;
        $package eq caller or die;
        $_attr_data{$package} = ref($_[0]) ? $_[0] : {@_};
    }
    __PACKAGE__->_set_addr_data(
        '_root_entry1' => [ undef, 'read/write'],
        '_root_entry2' => [ undef, 'read'],
    );
}

package My::Derived {
    use parent -norequire, 'My::Base';
    __PACKAGE__->_set_addr_data(
        '__some_entry1' => [ undef, 'read' ],
    );
}

package My::Derived::Derived {
    use parent -norequire, 'My::Derived';
    __PACKAGE__->_set_addr_data(
        '__some_entry1' => [ 123, 'read/write' ],
        '__some_entry2' => [ 456, 'read/write' ],
    );
}

use Data::Dumper;
print Dumper { My::Derived::Derived->_get_attr_data };

    [download]

    Best answer: you've basically just re-implemented a much worse version of Moose's metaobject protocol. Use Moose.

    toby döt ink
[reply]
[d/l]

      Thank you all so much. So many cool answers and that so quick. I'm impressed.

      It took me a while to understand everything. Now I understood it completely and your code is working successfully.

      Because my code is also using the _get_attr_data as object and not only as package, I had to rewrite the beginning of _get_attr_data. And I added another cache to this class method, so that not each time the attribute data of a inherited class has to be recomputed again.

      ...
    # Encapsulated class data

    my %_attr_data; # for each package: stores reference to its attrib
+ute data only
    my %_mro_cache;
    my %_attr_data_cache; # for each package stores reference to its a
+ttribute data + inherited attribute data

    # Class methods to operate on encapsulated class data

    sub _get_attr_data
    {
        my $caller = shift;
        my $package = ref($caller) || $caller;
        return %{$_attr_data_cache{$package}} if defined $_attr_data_c
+ache{$package};      
        my @parents = @{ $_mro_cache{$package} ||= mro::get_linear_isa
+($package) };
        my %return;
        for my $parent (@parents)
        {
            # assure that a reference is inside $_attr_data{$parent}
            ref $_attr_data{$parent} or next;
            for my $attr (keys %{$_attr_data{$parent}})
            {
                $return{$attr} ||= $_attr_data{$parent}{$attr};
            }
        }

        $_attr_data_cache{$package} = {%return};
        
        return %return;
    }
...

      [download]

      In this case the %_mro_cache should not be needed anymore. Because this method returns if it already handled the attribute data of an inherited package before. Is this method rewritten in a good manner?

      Of course you convinced me. I'll learn Moo or Moose and stop using my concept.

      Ah, and one other question. In the documentation of ref they write that a direct truth test could be wrong, because 0 which is false could be returned for a reference. Could this happen in my case? When would ref return a 0 for a reference? Would you always recommend to test against the empty string?

[reply]
[d/l]
[select]

        It took me a while to understand everything.

        I do often write quite dense code, compressing a lot of ideas into just a few statenments. For example, a lot of people would do this in at least two lines of code:

        my @parents = @{ $_mro_cache{$package} ||= mro::get_linear_isa($packag
+e) };

        [download]

        And I added another cache to this class method, so that not each time the attribute data of a inherited class has to be recomputed again.

        Yeah, caching the hashref like you're doing is probably a good idea. A more efficient one than caching the result of mro::get_linear_isa. The disadvantage is that if _set_attr_data gets called on a class after _get_attr_data it will invalidate the cached data for that class, plus the cached data for any derived classes. I would love to sound clever and claim that's why I didn't do it that way, but honestly, I just didn't think of it!

        The invalidation issue can be easily solved by putting %_attr_data_cache=(); in _set_attr_data. Yes, this wipes out your whole cache whenever _set_attr_data gets called, but in most cases, your _set_attr_data calls will all happen early on, before _get_attr_data ever gets called, so it won't cause any practical slow downs.

        I'll learn Moo or Moose and stop using my concept.

        I mean, there's certainly nothing wrong with rolling your own as a learning exercise, but the existing solutions on CPAN offer some really good and useful features, have optimized the hell out of everything, and have already thought through all the weird edge cases and gotchas.

        As well as Moose and Moo, consider Class::Tiny if you need a really light solution, even lighter than Moo.

        Moose and Moo each have a fairly interoperable syntax, though there are minor differences. Class::Tiny differs quite a lot in syntax but it interacts pretty well with Moo (and Moose? Not sure!) in terms of inheritance. You can write a base class with Class::Tiny and derived class with Moo, and things should "just work".

        In the documentation of ref they write that a direct truth test could be wrong, because 0 which is false could be returned for a reference. Could this happen in my case? When would ref return a 0 for a reference? Would you always recommend to test against the empty string?

        ref doesn't just randomly return '0' for fun sometimes, but will do so in one very specific situation: you can create a package called '0' and bless stuff into it. But I'd argue that anybody who is doing that is probably intending for you to treat their blessed references as if they were non-references. (Otherwise they'd have no reason to choose such a bizarre package name.) So for this reason, I wouldn't normally recommend checking to see if ref returned an actual 0.

        toby döt ink
[reply]
[d/l]
[select]
Re: Class attribute handling
by NERDVANA (Priest) on Dec 11, 2019 at 21:16 UTC

    The code you are experimenting with is maybe interesting from an academic standpoint, but it will perform worse than the code generated by Moo or Moose, and is clearly more effort to write. As far as I can see, it doesn't solve any problem that Moo can't solve. And if you use it to write a module for someone else to use, it hits them with an extra learning curve to be able to extend your code. So... there's really no valid reason to ever use it in production.

    If you want a "bare interpreter" perl class with no features, but which experiments with the true underlying perl object model, use this pattern:

    package MyClass;
sub new {
  my $class= shift;
  my %self= @_ ==1 && ref $_[0] eq 'HASH'? %{ $_[0] } : @_;
  bless \%self, $class;
}
sub attribite1 {  # read-only accessor
  $_[0]{attribute1}
}
sub attribute2 {  # read-write accessor
  $_[0]{attribute2}= $_[1] if @_ > 1;
  $_[0]{attribute2}
}

    [download]

    After you understand that, there's really nothing left to learn about perl's object mechanics.

    If you want a tool to help you generate that pattern on larger-scale classes with more specific requirements, and help document the design so that others can make use of the class, then use Moo or Moose: 

    package MyClass;
use Moo;
has attribute1 => ( is => 'ro' );
has attribute2 => ( is => 'rw' );

    [download]
    I'm not saying that Moo(se) solve all problems well, but if you want to set out to write a better object system you should at least start by studying the internals of Moo(se) as both of them are using better internal techniques than that code from "Object Oriented Perl". The main thing they do better is to "eval" compiled versions of the constructor and accessors, or even make use of Class::XSAcessor.
[reply]
[d/l]
[select]

Back to Seekers of Perl Wisdom