Сначала я начну с нескольких комментариев, а затем перейду к сути вашего вопроса.
OO Perl немного отличается от других систем OO. Существует очень тонкий слой базовой поддержки ОО, который позволяет вашим объектам делать практически все, что вы захотите. С другой стороны, вы можете заставить ваши объекты делать все, что вы хотите. Классический OO Perl включает в себя много стандартного кода, поскольку вы реализуете аксессоры и мутаторы для каждого атрибута, возможно, добавляете проверку типов и так далее. Это привело к появлению широкого спектра инструментов для автоматизации производства шаблонного кода.
Есть три способа, которыми я подхожу к OO Perl: Moose, классический хэш, основанный на ручном кодировании, и Class :: Struct. Moose отлично подходит для систем, где у вас есть сложные потребности, но он сильно влияет на время запуска приложения. Если время запуска важно для вашего приложения, о Moose пока не может быть и речи. Class :: Struct - отличный способ собрать наименьший общий знаменатель, быстрое и простое ОО-приложение вместе, с другой стороны, оно не поддерживает наследование. Вот тут-то и приходит ООП с ручным кодированием. Если Moose или Class :: Struct не являются жизнеспособными вариантами по тем или иным причинам, я возвращаюсь к основам. Эта стратегия хорошо сработала для меня. Единственное изменение, которое я почувствовал необходимость сделать за последние несколько лет, - это добавить Moose в мой стандартный инструментарий. Это долгожданное дополнение.
Объектно-ориентированный Perl Дамиана Конвея - это удивительная книга, которая ясно объясняет ООП, как работает ОО-Perl и как создавать объекты, которые могут делать удивительные вещи. Это немного устарело, но книга все еще держит. Любой серьезный ученик OO Perl должен прочитать эту книгу.
Теперь, на ваш вопрос -
Мне кажется, что breed2 - это не атрибут вашего объекта, а метод.
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";
Вещи становятся немного неприятнее, если вы хотите сохранить набор предопределенных пород, и breed2 выбирает объект породы по имени, если значение не установлено.
Эта упрощенная реализация Cat использует данные класса для отслеживания разрешенных пород кошек, а
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;
}
Теперь давайте рассмотрим решение Moose, в котором используются всевозможные дополнительные возможности, такие как приведение типов и перегрузка:
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";