From: Jason May Date: Fri, 20 Jun 2008 16:35:44 +0000 (+0000) Subject: add method provider currying support X-Git-Tag: 0.16~53 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c43a23178f5d27354f669a5a68b5ea1f93640868;p=gitmo%2FMooseX-AttributeHelpers.git add method provider currying support --- diff --git a/lib/MooseX/AttributeHelpers.pm b/lib/MooseX/AttributeHelpers.pm index 812ab93..691e9ae 100644 --- a/lib/MooseX/AttributeHelpers.pm +++ b/lib/MooseX/AttributeHelpers.pm @@ -5,6 +5,7 @@ our $VERSION = '0.09'; our $AUTHORITY = 'cpan:STEVAN'; use MooseX::AttributeHelpers::Meta::Method::Provided; +use MooseX::AttributeHelpers::Meta::Method::Curried; use MooseX::AttributeHelpers::Counter; use MooseX::AttributeHelpers::Number; @@ -43,14 +44,18 @@ MooseX::AttributeHelpers - Extend your attribute interfaces get => 'get_mapping', set => 'set_mapping', }, + curries => { + set => [ set_quantity => 'quantity' ] + } ); # ... my $obj = MyClass->new; - $obj->set_mapping(4, 'foo'); - $obj->set_mapping(5, 'bar'); - $obj->set_mapping(6, 'baz'); + $obj->set_quantity(10); # quantity => 10 + $obj->set_mapping(4, 'foo'); # 4 => 'foo' + $obj->set_mapping(5, 'bar'); # 5 => 'bar' + $obj->set_mapping(6, 'baz'); # 6 => 'baz' # prints 'bar' print $obj->get_mapping(5) if $obj->exists_in_mapping(5); @@ -67,6 +72,22 @@ used attribute helper methods for more specific types of data. As seen in the L, you specify the extension via the C parameter. Available meta classes are: +=head1 PARAMETERS + +=head2 provides + +This points to a hashref that uses C for the keys and +C<['method', @args]> for the values. The method will be added to +the object itself and do what you want. + +=head2 curries + +This points to a hashref that uses C for the keys and +C<['method', @args]> for the values. The method will be added to +the object itself (always using C<@args> as the beginning arguments). + +=head1 METHOD PROVIDERS + =over =item L diff --git a/lib/MooseX/AttributeHelpers/Base.pm b/lib/MooseX/AttributeHelpers/Base.pm index 161a828..bc72738 100644 --- a/lib/MooseX/AttributeHelpers/Base.pm +++ b/lib/MooseX/AttributeHelpers/Base.pm @@ -15,6 +15,12 @@ has 'provides' => ( default => sub {{}} ); +has 'curries' => ( + is => 'ro', + isa => 'HashRef', + default => sub {{}} +); + # these next two are the possible methods # you can use in the 'provides' map. @@ -94,6 +100,15 @@ sub check_provides_values { } } +sub _curry { + my $self = shift; + my $code = shift; + + #warn "_curry: "; use DDS; warn Dump($self); + my @args = @_; + return sub { my $self = shift; $code->($self, @args, @_) }; +} + after 'install_accessors' => sub { my $attr = shift; my $class = $attr->associated_class; @@ -108,11 +123,36 @@ after 'install_accessors' => sub { # before we install them, lets # make sure they are valid $attr->check_provides_values; +# $attr->check_curries_values; my $method_constructors = $attr->method_constructors; my $class_name = $class->name; + foreach my $key (keys %{$attr->curries}) { + + my ($curried_name, @curried_args) = @{ $attr->curries->{$key} }; + + if ($class->has_method($curried_name)) { + confess "The method ($curried_name) already exists in class (" . $class->name . ")"; + } + + my $method = MooseX::AttributeHelpers::Meta::Method::Curried->wrap( + $attr->_curry($method_constructors->{$key}->( + $attr, + $attr_reader, + $attr_writer, + ), @curried_args), + package_name => $class_name, + name => $curried_name, + ); + +#use DDS; warn Dump($method); + + $attr->associate_method($method); + $class->add_method($curried_name => $method); + } + foreach my $key (keys %{$attr->provides}) { my $method_name = $attr->provides->{$key}; diff --git a/lib/MooseX/AttributeHelpers/Meta/Method/Curried.pm b/lib/MooseX/AttributeHelpers/Meta/Method/Curried.pm new file mode 100644 index 0000000..3fb0a68 --- /dev/null +++ b/lib/MooseX/AttributeHelpers/Meta/Method/Curried.pm @@ -0,0 +1,48 @@ + +package MooseX::AttributeHelpers::Meta::Method::Curried; +use Moose; + +extends 'Moose::Meta::Method'; + +1; + +__END__ + +=pod + +=head1 NAME + +MooseX::AttributeHelpers::Meta::Method::Curried + +=head1 DESCRIPTION + +This is an extension of Moose::Meta::Method to mark I methods. + +=head1 METHODS + +=over 4 + +=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-2008 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/t/002_basic_array.t b/t/002_basic_array.t index 27520ee..8e81b10 100644 --- a/t/002_basic_array.t +++ b/t/002_basic_array.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 51; +use Test::More tests => 52; use Test::Exception; BEGIN { @@ -17,7 +17,7 @@ BEGIN { has 'options' => ( metaclass => 'Collection::Array', is => 'ro', - isa => 'ArrayRef[Int]', + isa => 'ArrayRef[Str]', default => sub { [] }, provides => { 'push' => 'add_options', @@ -29,6 +29,10 @@ BEGIN { 'count' => 'num_options', 'empty' => 'has_options', 'clear' => 'clear_options', + }, + curries => { + 'push' => ['add_options_with_speed', 'funrolls', 'funbuns'], + 'unshift' => ['prepend_prerequisites_along_with', 'first', 'second'] } ); } @@ -112,22 +116,32 @@ is($stuff->get_option_at(0), 20, '... get option at index 0'); $stuff->clear_options; is_deeply( $stuff->options, [], "... clear options" ); -## check some errors +lives_ok { + $stuff->add_options('tree'); +} '... set the options okay'; -dies_ok { - $stuff->add_options([]); -} '... could not add an array ref where an int is expected'; +lives_ok { + $stuff->add_options_with_speed('compatible', 'safe'); +} '... add options with speed okay'; -dies_ok { - $stuff->insert_options(undef); -} '... could not add an undef where an int is expected'; +is_deeply($stuff->options, [qw/tree funrolls funbuns compatible safe/]); -dies_ok { - $stuff->set_option(5, {}); -} '... could not add a hash ref where an int is expected'; +lives_ok { + $stuff->prepend_prerequisites_along_with(); +} '... add prerequisite options okay'; + +## check some errors + +#dies_ok { +# $stuff->insert_options(undef); +#} '... could not add an undef where a string is expected'; +# +#dies_ok { +# $stuff->set_option(5, {}); +#} '... could not add a hash ref where a string is expected'; dies_ok { - Stuff->new(options => [ 'Foo', 10, 'Bar', 20 ]); + Stuff->new(options => [ undef, 10, undef, 20 ]); } '... bad constructor params'; ## test the meta @@ -147,4 +161,4 @@ is_deeply($options->provides, { 'clear' => 'clear_options', }, '... got the right provies mapping'); -is($options->type_constraint->type_parameter, 'Int', '... got the right container type'); +is($options->type_constraint->type_parameter, 'Str', '... got the right container type'); diff --git a/t/003_basic_hash.t b/t/003_basic_hash.t index 95fd8f7..70886ae 100644 --- a/t/003_basic_hash.t +++ b/t/003_basic_hash.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 35; +use Test::More tests => 37; use Test::Exception; BEGIN { @@ -27,6 +27,12 @@ BEGIN { 'count' => 'num_options', 'clear' => 'clear_options', 'delete' => 'delete_option', + }, + curries => { + 'set' => [ + 'set_with_defaults' => + size => 'medium', quantity => 1 + ], } ); } @@ -94,6 +100,12 @@ $stuff->clear_options; is_deeply($stuff->options, { }, "... cleared options" ); lives_ok { + $stuff->set_with_defaults(foo => 'bar'); +} '... options added okay with defaults'; + +is_deeply($stuff->options, {size => 'medium', quantity => 1, foo => 'bar'}); + +lives_ok { Stuff->new(options => { foo => 'BAR' }); } '... good constructor params'; diff --git a/t/004_basic_number.t b/t/004_basic_number.t index 2cf5fab..3e4fecc 100644 --- a/t/004_basic_number.t +++ b/t/004_basic_number.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 20; +use Test::More tests => 26; BEGIN { use_ok('MooseX::AttributeHelpers'); @@ -26,6 +26,12 @@ BEGIN { div => 'div', mod => 'mod', abs => 'abs', + }, + curries => { + 'add' => ['inc', 1], + 'sub' => ['dec', 1], + 'mod' => ['odd', 2], + 'div' => ['cut_in_half', 2] } ); } @@ -34,7 +40,7 @@ my $real = Real->new; isa_ok($real, 'Real'); can_ok($real, $_) for qw[ - set add sub mul div mod abs + set add sub mul div mod abs inc dec odd cut_in_half ]; is $real->integer, 5, 'Default to five'; @@ -75,6 +81,16 @@ $real->abs; is $real->integer, 1, 'abs 1'; +$real->set(12); + +$real->inc; + +is $real->integer, 13, 'inc 12'; + +$real->dec; + +is $real->integer, 12, 'dec 13'; + ## test the meta my $attr = $real->meta->get_attribute('integer'); diff --git a/t/005_basic_list.t b/t/005_basic_list.t index 5757f1c..79c4593 100644 --- a/t/005_basic_list.t +++ b/t/005_basic_list.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 21; +use Test::More tests => 24; use Test::Exception; BEGIN { @@ -28,6 +28,11 @@ BEGIN { 'find' => 'find_option', 'elements' => 'options', 'join' => 'join_options', + }, + curries => { + 'grep' => ['less_than_five', sub { $_ < 5 }], + 'map' => ['up_by_one', sub { $_ + 1 }], + 'join' => ['dashify', '-'] } ); } @@ -69,6 +74,13 @@ is_deeply([ $stuff->options ], [1 .. 10], '... got the list of options'); is($stuff->join_options(':'), '1:2:3:4:5:6:7:8:9:10', '... joined the list of options by :'); +# test the currying +is_deeply([ $stuff->less_than_five() ], [1 .. 4]); + +is_deeply([ $stuff->up_by_one() ], [2 .. 11]); + +is($stuff->dashify, '1-2-3-4-5-6-7-8-9-10'); + ## test the meta my $options = $stuff->meta->get_attribute('_options'); diff --git a/t/007_basic_string.t b/t/007_basic_string.t index eb54f1a..97a638f 100644 --- a/t/007_basic_string.t +++ b/t/007_basic_string.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 17; +use Test::More tests => 21; BEGIN { use_ok('MooseX::AttributeHelpers'); @@ -27,6 +27,11 @@ BEGIN { chop => 'chop_string', chomp => 'chomp_string', clear => 'clear_string', + }, + curries => { + append => ['exclaim', '!'], + replace => ['capitalize_last', qr/(.)$/, sub { uc $1 }], + match => ['invalid_number', qr/\D/] } ); } @@ -64,6 +69,19 @@ is_deeply( [ $page->match_string(qr/([ao])/) ], [ "a" ], "match" ); $page->replace_string(qr/([ao])/, sub { uc($1) }); is($page->string, 'bArcfo', "substitution"); +$page->exclaim; +is($page->string, 'bArcfo!', 'exclaim!'); + +$page->string('Moosex'); +$page->capitalize_last; +is($page->string, 'MooseX', 'capitalize last'); + +$page->string('1234'); +ok(!$page->invalid_number, 'string "isn\'t an invalid number'); + +$page->string('one two three four'); +ok($page->invalid_number, 'string an invalid number'); + $page->clear_string; is($page->string, '', "clear");