From: Stevan Little Date: Sun, 2 Sep 2007 14:01:11 +0000 (+0000) Subject: now uses faster methods for accessors and some other minor cleanup stuff X-Git-Tag: 0.18_01~65 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=457dc4fbcdbffb359481532bdb4d4f17d0fd20be;p=gitmo%2FMooseX-AttributeHelpers.git now uses faster methods for accessors and some other minor cleanup stuff --- diff --git a/ChangeLog b/ChangeLog index d83a1a9..a97147d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,22 @@ Revision history for Perl extension MooseX-AttributeHelpers +0.02 + * MooseX::AttributeHelpers::Base + - now providing subrefs for the reader and writer + methods to all the method provider constructors + (this should speed things up quite a bit). + - all method providers now use this internally + + * MooseX::AttributeHelpers::Counter + - added the 'reset' method + + * MooseX::AttributeHelpers::Collection::Array + - Extracted the List method provider role from + Array and made Array consume List. + + + MooseX::AttributeHelpers::Collection::List + - created the Collection::List metaclass + derived from parts of the old Collection::Array + 0.01 Mon. Aug. 13, 2007 - module released to CPAN \ No newline at end of file diff --git a/lib/MooseX/AttributeHelpers.pm b/lib/MooseX/AttributeHelpers.pm index 3fe261b..8e71ba9 100644 --- a/lib/MooseX/AttributeHelpers.pm +++ b/lib/MooseX/AttributeHelpers.pm @@ -1,13 +1,14 @@ package MooseX::AttributeHelpers; -our $VERSION = '0.01'; +our $VERSION = '0.02'; our $AUTHORITY = 'cpan:STEVAN'; use MooseX::AttributeHelpers::Meta::Method::Provided; use MooseX::AttributeHelpers::Counter; use MooseX::AttributeHelpers::Number; +use MooseX::AttributeHelpers::Collection::List; use MooseX::AttributeHelpers::Collection::Array; use MooseX::AttributeHelpers::Collection::Hash; @@ -80,6 +81,10 @@ Common methods for hash references. Common methods for array references. +=item L + +Common list methods for array references. + =back =head1 CAVEAT diff --git a/lib/MooseX/AttributeHelpers/Base.pm b/lib/MooseX/AttributeHelpers/Base.pm index 77631ee..95f8b72 100644 --- a/lib/MooseX/AttributeHelpers/Base.pm +++ b/lib/MooseX/AttributeHelpers/Base.pm @@ -3,7 +3,7 @@ package MooseX::AttributeHelpers::Base; use Moose; use Moose::Util::TypeConstraints; -our $VERSION = '0.01'; +our $VERSION = '0.02'; our $AUTHORITY = 'cpan:STEVAN'; extends 'Moose::Meta::Attribute'; @@ -100,6 +100,24 @@ sub check_provides_values { after 'install_accessors' => sub { my $attr = shift; my $class = $attr->associated_class; + + # grab the reader and writer methods + # as well, this will be useful for + # our method provider constructors + my ($attr_reader, $attr_writer); + if (my $reader = $attr->get_read_method) { + $attr_reader = $class->get_method($reader); + } + else { + $attr_reader = sub { $attr->get_value(@_) }; + } + + if (my $writer = $attr->get_write_method) { + $attr_writer = $class->get_method($writer); + } + else { + $attr_writer = sub { $attr->set_value(@_) }; + } # before we install them, lets # make sure they are valid @@ -109,8 +127,12 @@ after 'install_accessors' => sub { foreach my $key (keys %{$attr->provides}) { - my $method_name = $attr->provides->{$key}; - my $method_body = $method_constructors->{$key}->($attr); + my $method_name = $attr->provides->{$key}; + my $method_body = $method_constructors->{$key}->( + $attr, + $attr_reader, + $attr_writer, + ); if ($class->has_method($method_name)) { confess "The method ($method_name) already exists in class (" . $class->name . ")"; diff --git a/lib/MooseX/AttributeHelpers/Collection/Array.pm b/lib/MooseX/AttributeHelpers/Collection/Array.pm index 48e6cec..ec8c750 100644 --- a/lib/MooseX/AttributeHelpers/Collection/Array.pm +++ b/lib/MooseX/AttributeHelpers/Collection/Array.pm @@ -39,7 +39,7 @@ MooseX::AttributeHelpers::Collection::Array use MooseX::AttributeHelpers; has 'options' => ( - metaclass => 'Collection', + metaclass => 'Collection::Array', is => 'ro', isa => 'ArrayRef[Int]', default => sub { [] }, diff --git a/lib/MooseX/AttributeHelpers/Collection/List.pm b/lib/MooseX/AttributeHelpers/Collection/List.pm new file mode 100644 index 0000000..f0bbeb0 --- /dev/null +++ b/lib/MooseX/AttributeHelpers/Collection/List.pm @@ -0,0 +1,89 @@ + +package MooseX::AttributeHelpers::Collection::List; +use Moose; + +our $VERSION = '0.01'; +our $AUTHORITY = 'cpan:STEVAN'; + +use MooseX::AttributeHelpers::MethodProvider::List; + +extends 'MooseX::AttributeHelpers::Collection'; + +has '+method_provider' => ( + default => 'MooseX::AttributeHelpers::MethodProvider::List' +); + +sub helper_type { 'ArrayRef' } + +no Moose; + +# register the alias ... +package Moose::Meta::Attribute::Custom::Collection::List; +sub register_implementation { 'MooseX::AttributeHelpers::Collection::List' } + + +1; + +__END__ + +=pod + +=head1 NAME + +MooseX::AttributeHelpers::Collection::List + +=head1 SYNOPSIS + + package Stuff; + use Moose; + use MooseX::AttributeHelpers; + + has 'options' => ( + metaclass => 'Collection::List', + is => 'ro', + isa => 'ArrayRef[Int]', + default => sub { [] }, + provides => { + map => 'map_options', + grep => 'fitler_options', + } + ); + +=head1 DESCRIPTION + +This module provides an List attribute which provides a number of +list operations. See L +for more details. + +=head1 METHODS + +=over 4 + +=item B + +=item B + +=item B + +=back + +=head1 BUGS + +All complex software has bugs lurking in it, and this module is no +exception. If you find a bug please either email me, or add the bug +to cpan-RT. + +=head1 AUTHOR + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/MooseX/AttributeHelpers/MethodProvider/Array.pm b/lib/MooseX/AttributeHelpers/MethodProvider/Array.pm index 2b294a7..7ce54a9 100644 --- a/lib/MooseX/AttributeHelpers/MethodProvider/Array.pm +++ b/lib/MooseX/AttributeHelpers/MethodProvider/Array.pm @@ -1,8 +1,14 @@ package MooseX::AttributeHelpers::MethodProvider::Array; use Moose::Role; +our $VERSION = '0.03'; +our $AUTHORITY = 'cpan:STEVAN'; + +with 'MooseX::AttributeHelpers::MethodProvider::List'; + sub push : method { - my ($attr) = @_; + my ($attr, $reader, $writer) = @_; + if ($attr->has_container_type) { my $container_type_constraint = $attr->container_type_constraint; return sub { @@ -10,26 +16,26 @@ sub push : method { $container_type_constraint->check($_) || confess "Value " . ($_||'undef') . " did not pass container type constraint" foreach @_; - CORE::push @{$attr->get_value($instance)} => @_; + CORE::push @{$reader->($instance)} => @_; }; } else { return sub { my $instance = CORE::shift; - CORE::push @{$attr->get_value($instance)} => @_; + CORE::push @{$reader->($instance)} => @_; }; } } sub pop : method { - my ($attr) = @_; + my ($attr, $reader, $writer) = @_; return sub { - CORE::pop @{$attr->get_value($_[0])} + CORE::pop @{$reader->($_[0])} }; } sub unshift : method { - my ($attr) = @_; + my ($attr, $reader, $writer) = @_; if ($attr->has_container_type) { my $container_type_constraint = $attr->container_type_constraint; return sub { @@ -37,89 +43,48 @@ sub unshift : method { $container_type_constraint->check($_) || confess "Value " . ($_||'undef') . " did not pass container type constraint" foreach @_; - CORE::unshift @{$attr->get_value($instance)} => @_; + CORE::unshift @{$reader->($instance)} => @_; }; } else { return sub { my $instance = CORE::shift; - CORE::unshift @{$attr->get_value($instance)} => @_; + CORE::unshift @{$reader->($instance)} => @_; }; } } sub shift : method { - my ($attr) = @_; + my ($attr, $reader, $writer) = @_; return sub { - CORE::shift @{$attr->get_value($_[0])} + CORE::shift @{$reader->($_[0])} }; } sub get : method { - my ($attr) = @_; + my ($attr, $reader, $writer) = @_; return sub { - $attr->get_value($_[0])->[$_[1]] + $reader->($_[0])->[$_[1]] }; } sub set : method { - my ($attr) = @_; + my ($attr, $reader, $writer) = @_; if ($attr->has_container_type) { my $container_type_constraint = $attr->container_type_constraint; return sub { ($container_type_constraint->check($_[2])) || confess "Value " . ($_[2]||'undef') . " did not pass container type constraint"; - $attr->get_value($_[0])->[$_[1]] = $_[2] + $reader->($_[0])->[$_[1]] = $_[2] }; } else { return sub { - $attr->get_value($_[0])->[$_[1]] = $_[2] + $reader->($_[0])->[$_[1]] = $_[2] }; } } -sub count : method { - my ($attr) = @_; - return sub { - scalar @{$attr->get_value($_[0])} - }; -} - -sub empty : method { - my ($attr) = @_; - return sub { - scalar @{$attr->get_value($_[0])} ? 1 : 0 - }; -} - -sub find : method { - my ($attr) = @_; - return sub { - my ($instance, $predicate) = @_; - foreach my $val (@{$attr->get_value($instance)}) { - return $val if $predicate->($val); - } - return; - }; -} - -sub map : method { - my ($attr) = @_; - return sub { - my ($instance, $f) = @_; - CORE::map { $f->($_) } @{$attr->get_value($instance)} - }; -} - -sub grep : method { - my ($attr) = @_; - return sub { - my ($instance, $predicate) = @_; - CORE::grep { $predicate->($_) } @{$attr->get_value($instance)} - }; -} - 1; __END__ @@ -145,20 +110,13 @@ L. =head1 PROVIDED METHODS -=over 4 +This module also consumes the B method providers, to +see those provied methods, refer to that documentation. -=item B - -=item B - -=item B +=over 4 =item B -=item B - -=item B - =item B =item B diff --git a/lib/MooseX/AttributeHelpers/MethodProvider/Counter.pm b/lib/MooseX/AttributeHelpers/MethodProvider/Counter.pm index 4c810fe..673d4d7 100644 --- a/lib/MooseX/AttributeHelpers/MethodProvider/Counter.pm +++ b/lib/MooseX/AttributeHelpers/MethodProvider/Counter.pm @@ -2,14 +2,22 @@ package MooseX::AttributeHelpers::MethodProvider::Counter; use Moose::Role; +our $VERSION = '0.03'; +our $AUTHORITY = 'cpan:STEVAN'; + +sub reset : method { + my ($attr, $reader, $writer) = @_; + return sub { $writer->($_[0], $attr->default($_[0])) }; +} + sub inc { - my $attr = shift; - return sub { $attr->set_value($_[0], $attr->get_value($_[0]) + 1) }; + my ($attr, $reader, $writer) = @_; + return sub { $writer->($_[0], $reader->($_[0]) + 1) }; } sub dec { - my $attr = shift; - return sub { $attr->set_value($_[0], $attr->get_value($_[0]) - 1) }; + my ($attr, $reader, $writer) = @_; + return sub { $writer->($_[0], $reader->($_[0]) - 1) }; } 1; @@ -43,6 +51,8 @@ L. =item B +=item B + =back =head1 BUGS diff --git a/lib/MooseX/AttributeHelpers/MethodProvider/Hash.pm b/lib/MooseX/AttributeHelpers/MethodProvider/Hash.pm index 986c085..cff3237 100644 --- a/lib/MooseX/AttributeHelpers/MethodProvider/Hash.pm +++ b/lib/MooseX/AttributeHelpers/MethodProvider/Hash.pm @@ -1,54 +1,57 @@ package MooseX::AttributeHelpers::MethodProvider::Hash; use Moose::Role; +our $VERSION = '0.01'; +our $AUTHORITY = 'cpan:STEVAN'; + sub exists : method { - my ($attr) = @_; - return sub { exists $attr->get_value($_[0])->{$_[1]} ? 1 : 0 }; + my ($attr, $reader, $writer) = @_; + return sub { exists $reader->($_[0])->{$_[1]} ? 1 : 0 }; } sub get : method { - my ($attr) = @_; - return sub { $attr->get_value($_[0])->{$_[1]} }; + my ($attr, $reader, $writer) = @_; + return sub { $reader->($_[0])->{$_[1]} }; } sub set : method { - my ($attr) = @_; + my ($attr, $reader, $writer) = @_; if ($attr->has_container_type) { my $container_type_constraint = $attr->container_type_constraint; return sub { ($container_type_constraint->check($_[2])) || confess "Value " . ($_[2]||'undef') . " did not pass container type constraint"; - $attr->get_value($_[0])->{$_[1]} = $_[2] + $reader->($_[0])->{$_[1]} = $_[2] }; } else { - return sub { $attr->get_value($_[0])->{$_[1]} = $_[2] }; + return sub { $reader->($_[0])->{$_[1]} = $_[2] }; } } sub keys : method { - my ($attr) = @_; - return sub { keys %{$attr->get_value($_[0])} }; + my ($attr, $reader, $writer) = @_; + return sub { keys %{$reader->($_[0])} }; } sub values : method { - my ($attr) = @_; - return sub { values %{$attr->get_value($_[0])} }; + my ($attr, $reader, $writer) = @_; + return sub { values %{$reader->($_[0])} }; } sub count : method { - my ($attr) = @_; - return sub { scalar keys %{$attr->get_value($_[0])} }; + my ($attr, $reader, $writer) = @_; + return sub { scalar keys %{$reader->($_[0])} }; } sub empty : method { - my ($attr) = @_; - return sub { scalar keys %{$attr->get_value($_[0])} ? 1 : 0 }; + my ($attr, $reader, $writer) = @_; + return sub { scalar keys %{$reader->($_[0])} ? 1 : 0 }; } sub delete : method { - my ($attr) = @_; - return sub { delete $attr->get_value($_[0])->{$_[1]} }; + my ($attr, $reader, $writer) = @_; + return sub { delete $reader->($_[0])->{$_[1]} }; } 1; diff --git a/lib/MooseX/AttributeHelpers/MethodProvider/List.pm b/lib/MooseX/AttributeHelpers/MethodProvider/List.pm new file mode 100644 index 0000000..952481e --- /dev/null +++ b/lib/MooseX/AttributeHelpers/MethodProvider/List.pm @@ -0,0 +1,106 @@ +package MooseX::AttributeHelpers::MethodProvider::List; +use Moose::Role; + +our $VERSION = '0.02'; +our $AUTHORITY = 'cpan:STEVAN'; + +sub count : method { + my ($attr, $reader, $writer) = @_; + return sub { + scalar @{$reader->($_[0])} + }; +} + +sub empty : method { + my ($attr, $reader, $writer) = @_; + return sub { + scalar @{$reader->($_[0])} ? 1 : 0 + }; +} + +sub find : method { + my ($attr, $reader, $writer) = @_; + return sub { + my ($instance, $predicate) = @_; + foreach my $val (@{$reader->($instance)}) { + return $val if $predicate->($val); + } + return; + }; +} + +sub map : method { + my ($attr, $reader, $writer) = @_; + return sub { + my ($instance, $f) = @_; + CORE::map { $f->($_) } @{$reader->($instance)} + }; +} + +sub grep : method { + my ($attr, $reader, $writer) = @_; + return sub { + my ($instance, $predicate) = @_; + CORE::grep { $predicate->($_) } @{$reader->($instance)} + }; +} + +1; + +__END__ + +=pod + +=head1 NAME + +MooseX::AttributeHelpers::MethodProvider::List + +=head1 DESCRIPTION + +This is a role which provides the method generators for +L. + +=head1 METHODS + +=over 4 + +=item B + +=back + +=head1 PROVIDED METHODS + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=item B + +=back + +=head1 BUGS + +All complex software has bugs lurking in it, and this module is no +exception. If you find a bug please either email me, or add the bug +to cpan-RT. + +=head1 AUTHOR + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2007 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut diff --git a/lib/MooseX/AttributeHelpers/Number.pm b/lib/MooseX/AttributeHelpers/Number.pm index 10bba2e..2f92632 100644 --- a/lib/MooseX/AttributeHelpers/Number.pm +++ b/lib/MooseX/AttributeHelpers/Number.pm @@ -8,36 +8,42 @@ extends 'MooseX::AttributeHelpers::Base'; sub helper_type { 'Num' } +# NOTE: +# we don't use the method provider for this +# module since many of the names of the provied +# methods would conflict with keywords +# - SL + has '+method_constructors' => ( default => sub { return +{ set => sub { - my $attr = shift; - return sub { $attr->set_value($_[0], $_[1]) }; + my ($attr, $reader, $writer) = @_; + return sub { $writer->($_[0], $_[1]) }; }, add => sub { - my $attr = shift; - return sub { $attr->set_value($_[0], $attr->get_value($_[0]) + $_[1]) }; + my ($attr, $reader, $writer) = @_; + return sub { $writer->($_[0], $reader->($_[0]) + $_[1]) }; }, sub => sub { - my $attr = shift; - return sub { $attr->set_value($_[0], $attr->get_value($_[0]) - $_[1]) }; + my ($attr, $reader, $writer) = @_; + return sub { $writer->($_[0], $reader->($_[0]) - $_[1]) }; }, mul => sub { - my $attr = shift; - return sub { $attr->set_value($_[0], $attr->get_value($_[0]) * $_[1]) }; + my ($attr, $reader, $writer) = @_; + return sub { $writer->($_[0], $reader->($_[0]) * $_[1]) }; }, div => sub { - my $attr = shift; - return sub { $attr->set_value($_[0], $attr->get_value($_[0]) / $_[1]) }; + my ($attr, $reader, $writer) = @_; + return sub { $writer->($_[0], $reader->($_[0]) / $_[1]) }; }, mod => sub { - my $attr = shift; - return sub { $attr->set_value($_[0], $attr->get_value($_[0]) % $_[1]) }; + my ($attr, $reader, $writer) = @_; + return sub { $writer->($_[0], $reader->($_[0]) % $_[1]) }; }, abs => sub { - my $attr = shift; - return sub { $attr->set_value($_[0], abs($attr->get_value($_[0])) ) }; + my ($attr, $reader, $writer) = @_; + return sub { $writer->($_[0], abs($reader->($_[0])) ) }; }, } } diff --git a/t/001_basic_counter.t b/t/001_basic_counter.t index 5430d44..ff63f2c 100644 --- a/t/001_basic_counter.t +++ b/t/001_basic_counter.t @@ -19,8 +19,9 @@ BEGIN { isa => 'Int', default => sub { 0 }, provides => { - inc => 'inc_counter', - dec => 'dec_counter', + inc => 'inc_counter', + dec => 'dec_counter', + reset => 'reset_counter', } ); } @@ -31,6 +32,7 @@ isa_ok($page, 'MyHomePage'); can_ok($page, $_) for qw[ dec_counter inc_counter + reset_counter ]; is($page->counter, 0, '... got the default value'); @@ -44,6 +46,9 @@ is($page->counter, 2, '... got the incremented value (again)'); $page->dec_counter; is($page->counter, 1, '... got the decremented value'); +$page->reset_counter; +is($page->counter, 0, '... got the original value'); + # check the meta .. my $counter = $page->meta->get_attribute('counter'); @@ -54,7 +59,8 @@ is($counter->helper_type, 'Num', '... got the expected helper type'); is($counter->type_constraint->name, 'Int', '... got the expected type constraint'); is_deeply($counter->provides, { - inc => 'inc_counter', - dec => 'dec_counter', + inc => 'inc_counter', + dec => 'dec_counter', + reset => 'reset_counter', }, '... got the right provides methods'); diff --git a/t/005_basic_list.t b/t/005_basic_list.t new file mode 100644 index 0000000..83e6324 --- /dev/null +++ b/t/005_basic_list.t @@ -0,0 +1,75 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More no_plan => 1; +use Test::Exception; + +BEGIN { + use_ok('MooseX::AttributeHelpers'); +} + +{ + package Stuff; + use Moose; + + has 'options' => ( + metaclass => 'Collection::List', + is => 'ro', + isa => 'ArrayRef[Int]', + default => sub { [] }, + provides => { + 'count' => 'num_options', + 'empty' => 'has_options', + 'map' => 'map_options', + 'grep' => 'filter_options', + 'find' => 'find_option', + } + ); +} + +my $stuff = Stuff->new(options => [ 1 .. 10 ]); +isa_ok($stuff, 'Stuff'); + +can_ok($stuff, $_) for qw[ + num_options + has_options + map_options + filter_options + find_option +]; + +is_deeply($stuff->options, [1 .. 10], '... got options'); + +ok($stuff->has_options, '... we have options'); +is($stuff->num_options, 10, '... got 2 options'); + +is_deeply( +[ $stuff->filter_options(sub { $_[0] % 2 == 0 }) ], +[ 2, 4, 6, 8, 10 ], +'... got the right filtered values' +); + +is_deeply( +[ $stuff->map_options(sub { $_[0] * 2 }) ], +[ 2, 4, 6, 8, 10, 12, 14, 16, 18, 20 ], +'... got the right mapped values' +); + +is($stuff->find_option(sub { $_[0] % 2 == 0 }), 2, '.. found the right option'); + +## test the meta + +my $options = $stuff->meta->get_attribute('options'); +isa_ok($options, 'MooseX::AttributeHelpers::Collection::List'); + +is_deeply($options->provides, { + 'map' => 'map_options', + 'grep' => 'filter_options', + 'find' => 'find_option', + 'count' => 'num_options', + 'empty' => 'has_options', +}, '... got the right provies mapping'); + +is($options->container_type, 'Int', '... got the right container type');