cp-accessors.pl

#!/usr/bin/perl

# Напишите на Perl примитивный базовый класс MyApp::Accessor для
# использования в качестве базового класса для генерации ацессоров
# (методов которые сохраняют и отдают свойство объекта). Ацессоры должны
# работать настолько быстро, насколько это возможно в принципе. Какими
# технологиями/модулями, по вашему, лучше всего пользоваться в реальной
# разработке для создания ацессоров?
# P.S. Accessor – это примитивная функция, которая служит для доступа к
# свойству объекта извне. Т.е. $obj->property() – возвращает значение,
# а $obj->property($value) – устанавливает.

use Modern::Perl;
use DDP;

# -----------------------------------------------------------------------------
# Аксессоры - те же методы. На уровне пакета они создаются просто, см.
# функцию make_pkg_accessor(). При желании её можно спрятать в базовый
# класс. Не сделал это потому, что так проще создавать аксессоры до создания 
# объектов. И вообще, для любых объектов, которые к MyApp::Acceptor никакого
# отношения не имеют. На уровне конкретного объекта чуть сложней, здесь нужно 
# менять тип объекта. И вот этот метод уже точно имеет смысл делать внутри
# пакета, чтобы использовать уникальные имена.
# -----------------------------------------------------------------------------

make_pkg_accessor( 'MyApp::Acceptor', 'color' );
my $obj = MyApp::Acceptor->new();
$obj->show();
$obj->color('green');
say 'color => ' . $obj->color();
$obj->color('red');
say 'color => ' . $obj->color();

my $foo = MyApp::Acceptor->new();
$foo->make_obj_accessor('bar');
$foo->show();
$foo->bar('foo');
say 'bar => ' . $foo->bar();
$foo->bar('bar');
say 'bar => ' . $foo->bar();

# OK:
$foo->color('yellow');
say 'color => ' . $foo->color();

my $dead = MyApp::Acceptor->new();
$dead->make_obj_accessor('dead');
$dead->show();
$dead->dead('dead');
say 'dead => ' . $dead->dead();
$dead->dead('beef');
say 'dead => ' . $dead->dead();

# OK:
$dead->color('black');
say 'color => ' . $dead->color();

# Can't locate MyApp::Acceptor method "foo" via package "MyApp::Acceptor"...
# say 'foo => '.$obj->foo();

# Can't locate MyApp::Acceptor method "bar" via package "MyApp::Acceptor_a"...
#say 'bar => '.$dead->bar();

p $obj;
p $foo;
p $dead;

# -----------------------------------------------------------------------------
sub make_pkg_accessor
{
    my ( $package, $name ) = @_;
    unless ( $package->can($name) ) {
        no strict 'refs';
        *{"$package\::$name"} = sub {
            my ( $self, $value ) = @_;
            return $self->{_accessors}->{$name} unless defined $value;
            $self->{_accessors}->{$name} = $value;
            return $self->{_accessors}->{$name};
        };
    }
}

# ------------------------------------------------------------------------------
package MyApp::Acceptor;
use Modern::Perl;
use vars qw/$DERIVED/;

sub new
{
    my ($class) = @_;
    return bless { _obj_accessors => {}, }, $class;
}

sub show { printf "\n%s::show()\n", ref shift }

sub make_obj_accessor
{
    my ( $self, $name ) = @_;
    unless ( $self->can($name) ) {
        my $class = ref $self;
        $DERIVED //= __PACKAGE__.'_';
        $DERIVED .= 'a';
        no strict 'refs';
        @{ $DERIVED . '::ISA' }   = ($class);
        *{ $DERIVED . "::$name" } = sub {
            my ( $self, $value ) = @_;
            return $self->{_obj_accessors}->{$name} unless defined $value;
            $self->{_obj_accessors}->{$name} = $value;
            return $self->{_obj_accessors}->{$name};
        };
        bless $self, $DERIVED;
    }
}

# ------------------------------------------------------------------------------
1;