From 78d5589bd25be4ce3a9248153809aade9618bdcc Mon Sep 17 00:00:00 2001 From: Nicolas R Date: Tue, 31 Mar 2020 16:52:01 -0600 Subject: [PATCH] Basic and naive role implementation --- Changes | 3 ++ README.md | 26 ++++++++++++++ dist.ini | 5 ++- lib/Simple/Accessor.pm | 77 ++++++++++++++++++++++++++++++++++++++++-- t/lib/Role/Age.pm | 10 ++++++ t/lib/Role/Time.pm | 10 ++++++ t/lib/TestRole.pm | 13 +++++++ t/roles.t | 15 ++++++++ 8 files changed, 155 insertions(+), 4 deletions(-) create mode 100644 Changes create mode 100644 t/lib/Role/Age.pm create mode 100644 t/lib/Role/Time.pm create mode 100644 t/lib/TestRole.pm create mode 100644 t/roles.t diff --git a/Changes b/Changes new file mode 100644 index 0000000..b69824e --- /dev/null +++ b/Changes @@ -0,0 +1,3 @@ +{{$NEXT}} + +- Add basic/naive implementation of roles using 'with' diff --git a/README.md b/README.md index cecfa6d..8fa75e6 100644 --- a/README.md +++ b/README.md @@ -4,6 +4,32 @@ # NAME Simple::Accessor - very simple, light and powerful accessor +# SYNOPSIS + +```perl +package Role::Color; +use Simple::Accessor qw{color}; + +sub _build_color { 'red' } # default color + +package Car; + +# that s all what you need ! no more line required +use Simple::Accessor qw{brand hp}; + +with 'Role::Color'; + +sub _build_hp { 2 } +sub _build_brand { 'unknown' } + +package main; + +my $c = Car->new( brand => 'zebra' ); + +is $c->brand, 'zebra'; +is $c->color, 'red'; +``` + # DESCRIPTION Simple::Accessor provides a simple object layer without any dependency. diff --git a/dist.ini b/dist.ini index 70e9dde..33eecb7 100644 --- a/dist.ini +++ b/dist.ini @@ -1,5 +1,5 @@ name = Simple-Accessor -version = 1.11 +version = 1.12 author = Nicolas R. license = Perl_5 copyright_holder = Nicolas R. @@ -16,6 +16,9 @@ copyright_holder = Nicolas R. [GatherDir] exclude_filename = Makefile.PL +[NextRelease] +filename = Changes + [MetaJSON] ;[AutoMetaResources] ;bugtracker.rt = 1 diff --git a/lib/Simple/Accessor.pm b/lib/Simple/Accessor.pm index 135f1f9..2038f7e 100644 --- a/lib/Simple/Accessor.pm +++ b/lib/Simple/Accessor.pm @@ -1,5 +1,4 @@ package Simple::Accessor; - use strict; use warnings; @@ -8,6 +7,30 @@ use warnings; =head1 NAME Simple::Accessor - very simple, light and powerful accessor +=head1 SYNOPSIS + + package Role::Color; + use Simple::Accessor qw{color}; + + sub _build_color { 'red' } # default color + + package Car; + + # that s all what you need ! no more line required + use Simple::Accessor qw{brand hp}; + + with 'Role::Color'; + + sub _build_hp { 2 } + sub _build_brand { 'unknown' } + + package main; + + my $c = Car->new( brand => 'zebra' ); + + is $c->brand, 'zebra'; + is $c->color, 'red'; + =head1 DESCRIPTION Simple::Accessor provides a simple object layer without any dependency. @@ -109,13 +132,49 @@ None. The only public method provided is the classical import. =cut +my $INFO; + sub import { my ( $class, @attr ) = @_; my $from = caller(); + $INFO = {} unless defined $INFO; + $INFO->{$from} = {} unless defined $INFO->{$from}; + $INFO->{$from}->{'attributes'} = [ @attr ]; + + _add_with($from); _add_new($from); _add_accessors( to => $from, attributes => \@attr ); + + return; +} + +sub _add_with { + my $class = shift; + return unless $class; + + my $with = $class . '::with'; + { + no strict 'refs'; + *$with = sub { + my ( @what ) = @_; + + $INFO->{$class}->{'with'} = [] unless $INFO->{$class}->{'with'}; + push @{$INFO->{$class}->{'with'}}, @what; + + foreach my $module ( @what ) { + eval qq[require $module; 1] or die $@; + _add_accessors( + to => $class, + attributes => $INFO->{$module}->{attributes}, + from_role => $module + ); + } + + return; + }; + } } sub _add_new { @@ -157,12 +216,16 @@ sub _add_new { sub _add_accessors { my (%opts) = @_; - return unless $opts{to}; + return unless my $class = $opts{to}; my @attributes = @{ $opts{attributes} }; return unless @attributes; + my $from_role = $opts{from_role}; + foreach my $att (@attributes) { - my $accessor = $opts{to} . "::$att"; + my $accessor = $class . "::" . $att; + + die "$class: attribute '$att' is already defined." if $class->can($att); # allow symbolic refs to typeglob no strict 'refs'; @@ -177,6 +240,10 @@ sub _add_accessors { my $sub = '_' . $_ . '_' . $att; if ( $self->can( $sub ) ) { return unless $self->$sub($v); + } elsif ( $from_role ) { + if ( my $code = $from_role->can( $sub ) ) { + return unless $code->( $self, $v ); + } } } } @@ -187,6 +254,10 @@ sub _add_accessors { my $sub = '_' . $builder . '_' . $att; if ( $self->can( $sub ) ) { return $self->{$att} = $self->$sub(); + } elsif ( $from_role ) { + if ( my $code = $from_role->can( $sub ) ) { + return $self->{$att} = $code->( $self ); + } } } } diff --git a/t/lib/Role/Age.pm b/t/lib/Role/Age.pm new file mode 100644 index 0000000..3d95a8b --- /dev/null +++ b/t/lib/Role/Age.pm @@ -0,0 +1,10 @@ +package Role::Age; + +use strict; +use warnings; + +use Simple::Accessor qw{age}; + +sub _build_age { 42 } + +1; \ No newline at end of file diff --git a/t/lib/Role/Time.pm b/t/lib/Role/Time.pm new file mode 100644 index 0000000..5a93ac0 --- /dev/null +++ b/t/lib/Role/Time.pm @@ -0,0 +1,10 @@ +package Role::Time; + +use strict; +use warnings; + +use Simple::Accessor qw{date}; + +sub _build_date { '20210102' } + +1; \ No newline at end of file diff --git a/t/lib/TestRole.pm b/t/lib/TestRole.pm new file mode 100644 index 0000000..ec6af11 --- /dev/null +++ b/t/lib/TestRole.pm @@ -0,0 +1,13 @@ +package TestRole; + +use strict; +use warnings; + +use Simple::Accessor qw{name}; + +with 'Role::Age'; +with 'Role::Time'; + +sub _build_name { 'default-name' } + +1; \ No newline at end of file diff --git a/t/roles.t b/t/roles.t new file mode 100644 index 0000000..68d0e50 --- /dev/null +++ b/t/roles.t @@ -0,0 +1,15 @@ +use warnings; + +use Test::More tests => 4; +use FindBin; + +use lib $FindBin::Bin. '/lib'; + +use_ok 'TestRole'; + +my $o = TestRole->new(); +is $o->name, 'default-name'; +is $o->age, 42, 'default age'; +is $o->date, '20210102', 'default date'; + +1;