How can I reference the object when building it with Perl's Class::Struct?

Question

Hi ,

I am new to object oriented Perl and i have to access member variable of same object in another subrutine of same object. Sample code is here :

use Class::Struct;

struct Breed =>
{
    name  => '$',
    cross => '$',
};

struct Cat =>
[
    name     => '$',
    kittens  => '@',
    markings => '%',
    breed    => 'Breed',
    breed2 => '$',

];

my $cat = Cat->new( name     => 'Socks',
                    kittens  => ['Monica', 'Kenneth'],
                    markings => { socks=>1, blaze=>"white" },
                    breed    => { name=>'short-hair', cross=>1 },
                    ** //breed2 => sub { return $cat->breed->name;}**

                  );

print "Once a cat called ", $cat->name, "\n";
**print "(which was a ", $cat->breed->name, ")\n";**
print "had two kittens: ", join(' and ', @{$cat->kittens}), "\n";

But i am not sure how to use that $cat->breed->name in subroutine for breed2 ? Can some one help me with this.

Answer 1

Don't use Class::Struct use Moose.

package Breed;
use Moose;
has 'name'  => ( isa => 'Str', is => 'ro', required => 1 );
has 'cross' => ( isa => 'Bool', is => 'ro' );

package Cat;
use Moose;
has 'name'     => ( isa => 'Str', is => 'ro', required => 1 );
has 'kittens'  => ( isa => 'ArrayRef[Cat]', is => 'ro' );
has 'markings' => ( isa => 'HashRef', is => 'ro', default => sub { +{} } );
has 'breeds'   => ( isa => 'ArrayRef[Breed]', is => 'ro' );

package main;
use Modern::Perl;
my $cat = Cat->new({
  name       => 'Socks',
  , kittens  => [ Cat->new({name=>'Monica'}), Cat->new({name=>'Kenneth'}) ]
  , markings => { socks=>1, blaze=>"white" }
  , breeds   => [ Breed->new({ name=>'short-hair', cross => 1 }) ]
});

say "Once a cat called ", $cat->name;
say "Which was a:";
say "\t".$_->name for @{$cat->breeds};
say "had kittens:";
say "\t".$_->name for @{$cat->kittens};

In this scheme, a cat can have any number of Breeds, and a Cat can have any number of kittens which are also objects of Cat.

update to solve your problem specifically

1. You can make it implicit in the constructor the second breed is the first if it isn't supplied.

   package Cat; sub BUILD { my $self = shift; $self->breeds->[1] = $self->breeds->[0] if $self->breeds->[0] && ! $self->breeds->[1] }

2. You can pass in a token that identifies it as such, in the constructor (this should be easy but I can add an example if you want)

3. You can make Cat understand that if there is only one breed then both of the parents are the same

   package Cat; sub is_pure_bred { length @{$_[0]->breeds} == 1 ? 1 : 0 }

4. You can make ignore the breed of the cat, by setting it to undef, and determine the breed by that of the parents. This is because your breed is always a function of your lineage anyway. You can constraint this in a Moose trigger, the cat either requires two cat parents, or it requires a breed.

footnote Moose objects serialize fairly nice with XXX too:

... use XXX; YYY $cat;

--- !!perl/hash:Cat
breeds:
  - !!perl/hash:Breed
    cross: 1
    name: short-hair
kittens:
  - !!perl/hash:Cat
    markings: {}
    name: Monica
  - !!perl/hash:Cat
    markings: {}
    name: Kenneth
markings:
  blaze: white
  socks: 1
name: Socks
...

Answer 2

You can't use $cat->breed->name inside the Cat constructor. But you can define breed2() as a method after the constructor:

sub Cat::breed2 {
    my ($self) = @_;
    return $self->breed->name;
}

Answer 3

The problem in breed2 is that you are trying to refer to a variable that you haven't defined yet. It looks like it is the same name, but it's not the object you are creating. It's a bit of a chicken-and-egg problem.

I'm not so sure that you want an anonymous subroutine like that in that slot anyway. Are you just trying to shorten $cat->breed->name to $cat->breed2? You can start with undef in breed2 and change its value right after the constructor since you'll have the reference to the object then. However, even if you put a subroutine there, you have to dereference it:

my $cat = Cat->new( name     => 'Socks',
                    kittens  => ['Monica', 'Kenneth'],
                    markings => { socks=>1, blaze=>"white" },
                    breed    => { name=>'short-hair', cross=>1 },
                    breed2   => undef,

                  );
$cat->breed2( sub { $cat->breed->name } );

print "Once a cat called ", $cat->name, "\n";
print "(which was a ", $cat->breed2->(), ")\n";
print "had two kittens: ", join(' and ', @{$cat->kittens}), "\n";

Answer 4

First, I'll start with several comments, then I'll get to the meat of your question.

OO Perl is a bit different than other OO systems. There is a very thin layer of basic support for OO that makes it possible to make your objects do just about anything you want. On the down side, you can make your objects do just about anything you want. Classical OO Perl involves a lot of boilerplate code, as you implement accessors and mutators for each attribute, perhaps add type checking and so forth. This has given rise to a wide variety of tools to automate the production of boilerplate code.

There are three ways that I approach OO Perl: Moose, classical hash based all hand coded, and Class::Struct. Moose is great for systems where you have complex needs, but it has a big impact on app start-up time. If launch time is important for your application, Moose is, for now, out of the question. Class::Struct is a great way to get a lowest common denominator, quick, simple OO app together, on the downside it doesn't support inheritance. This is where hand coded OOP comes in. If Moose or Class::Struct aren't viable options for one reason or another, I fall back on the basics. This strategy has worked well for me. The only change I have felt the need to make over the last few years, is to add Moose to my standard toolkit. It's a welcome addition.

Damian Conway's Object Oriented Perl is an amazing book that clearly explains OOP, how OO Perl works, and how to build objects that can do amazing things. It's a bit dated, but the book still holds up. Any serious student of OO Perl should read this book.

Now, for your question--

It looks to me like breed2 is not an attribute of your object, it is instead a method.

use Class::Struct;
use strict;
use warnings;

struct Breed =>
{
    name  => '$',
    cross => '$',
};

struct Cat =>
[
    name     => '$',
    kittens  => '@',
    markings => '%',
    breed    => 'Breed',
];

my $cat = Cat->new( name     => 'Socks',
                    kittens  => ['Monica', 'Kenneth'],
                    markings => { socks=>1, blaze=>"white" },
                    breed    => { name=>'short-hair', cross=>1 },
                  );

# Delegate to Breed::name
sub Cat::breed2 {
    my $self = shift;

    my $breed = $self->breed;  # Get the breed object

    my $name;

    eval { $name = $breed->name(@_) };

    warn "No breed specified for ".( $self->name )."\n"
        unless defined $name;

    return $name;
}

print  "Once a cat called ", $cat->name, "\n",
       "(which was a ", $cat->breed2, ")\n",
       "had two kittens: ", join(' and ', @{$cat->kittens}), "\n";

Things get a bit hairier if you want to keep a set of pre-defined breeds, and have breed2 select a breed object by name if no value is set.

This stripped down Cat implementation uses class data to keep track of allowed cat breeds, and

package Cat;
use strict;
use warnings;
use Carp qw( croak );

my %breeds = map { $_->{name}, Breed->new( %$_ ) } (
    { name=>'short-hair', cross=>1 },
    { name=>'long-hair', cross=>1 },
    { name=>'siamese', cross=>0 },
);

sub new {
    my $class = shift;
    my %args = @_;

    my $self = {};
    bless $self, $class;

    for my $arg ( keys %args ) {
        $self->$arg( $args{$arg} ) if $self->can($arg);
    }

    return $self;
}

sub breed {
    my $self = shift;
    if( @_ ) {
        my $v = shift;
        croak "Illegal cat breed" unless eval {$v->isa( 'Breed' ) };
        $self->{breed} = $v;
    }

    return $self->{breed};
}

sub breed2 {
    my $self = shift;

    my @breed_args;

    if( @_ ) {
        my $v = shift;

        croak "$v is not a supported breed\n" 
            unless exists $breeds{$v};

        @breed_args = ( $breeds{$v} );
    }

    my $breed = $self->breed(@breed_args);

    return unless $breed;
    return $breed->name;
}

Now, lets look at a Moose solution that uses all sorts of advanced goodies like type coercion and overloading:

BEGIN {
    package Breed;
    use Moose;

    has 'name'  => ( isa => 'Str',  is => 'ro', required => 1 );
    has 'cross' => ( isa => 'Bool', is => 'ro', required => 1 );

    use overload '""' => \&_overload_string;

    sub _overload_string {
        my $self = shift;

        return $self->name;
    }

    __PACKAGE__->meta->make_immutable;    
    no Moose;
    1;
}

BEGIN {
    package Cat;

    use Moose;
    use Moose::Util::TypeConstraints;
    use Carp;

    subtype 'MyTypes::CatBreed' => as class_type('Breed');

    coerce 'MyTypes::CatBreed' => 
        from  'Str' 
        => via  { Cat->supported_breed_by_name( $_ ) };



    has 'name'     => ( isa => 'Str',  is => 'rw', required => 1 );
    has 'kittens'  => ( 
        traits      => ['Array'],
        is          => 'ro',
        isa         => 'ArrayRef[Str]',
        default     => sub{ [] },
        handles     => {
           all_kittens   => 'elements',
           add_kittens   => 'push',
           get_kitten    => 'get',
           count_kittens => 'count',
           has_kittens   => 'count',
       },
    );
    has 'markings' => ( 
        traits      => ['Hash'],
        is          => 'ro',
        isa         => 'HashRef[Str]',
        default     => sub{ {} },
        handles     => {
            set_marking    => 'set',
            get_marking    => 'get',
            has_marking    => 'exists',
            all_markings   => 'keys',
            delete_marking => 'delete',
        },
    );
    has 'breed'    => ( 
        isa    => 'MyTypes::CatBreed', 
        is     => 'ro', 
        coerce => 1,
    );

    my %breeds;
    sub supported_breed_by_name {
        my $class = shift;
        my $name  = shift;

        croak 'No breed name specified' 
            unless defined $name and length $name;

        return $breeds{$name};
    }

    sub add_breed {
        my $class = shift;
        my $breed  = shift;

        croak 'No breed specified' 
            unless eval { $breed->isa('Breed') };

        croak 'Breed already exists'
            if exists $breeds{$breed};

        $breeds{$breed} = $breed;

        return $class;
    }

    sub delete_breed {
        my $class = shift;
        my $name  = shift;

        croak 'No breed name specified' 
            unless defined $name and length $name;

        return delete $breeds{$name};
    }

    __PACKAGE__->meta->make_immutable;    
    no Moose;
    1;
}


# Set up the supported breeds
Cat->add_breed($_) for map Breed->new( %$_ ), (
    { name=>'short-hair', cross=>1 },
    { name=>'long-hair', cross=>1 },
    { name=>'siamese', cross=>0 },
);

# Make a cat
my $cat = Cat->new( name     => 'Socks',
                    kittens  => ['Monica', 'Kenneth'],
                    markings => { socks=>1, blaze=>"white" },
                    breed    => 'short-hair',
);

print 
    "Once a cat called ", $cat->name, "\n",
    "(which was a ", $cat->breed, ")\n",
    "had ", , " kittens: ", join(' and ', @{$cat->kittens}), "\n";

Answer 5

You can fix this in a few ways, here are two of them:

use warnings;
use strict;

sub say {print @_, "\n"}

use Class::Struct;

struct Breed =>
{
    name  => '$',
    cross => '$',
};

struct Cat =>
[
    name     => '$',
    kittens  => '@',
    markings => '%',
    breed    => 'Breed',
    breed2   => '$',

];

sub Cat::breed_name {shift->breed->name}  #create a new accessor method

my $cat; # or declare $cat first
$cat = Cat->new( name     => 'Socks',
                    kittens  => ['Monica', 'Kenneth'],
                    markings => { socks=>1, blaze=>"white" },
                    breed    => { name=>'short-hair', cross=>1 },
                    breed2 => sub { return $cat->breed->name;},
                    # this is now ok, but a bit awkward to call
                  );

print "Once a cat called ", $cat->name, "\n";
print "(which was a ", $cat->breed2->(), ")\n";  #returns then calls code ref
print "(which was a ", $cat->breed_name, ")\n";  #new accessor method
print "had two kittens: ", join(' and ', @{$cat->kittens}), "\n";

The reason your closure did not work right is because you can not close over a variable that is defined in the current statement. When the sub {...} tried to close around $cat it couldn't because it was not in scope yet. The solution is simply to predeclare the variable.

However, it doesn't seem like Class::Struct lets you install methods that way cleanly. Instead, adding a new accessor method to the Cat:: package lets you call the method as you would expect.