From: Stevan Little Date: Sun, 8 Apr 2007 03:19:30 +0000 (+0000) Subject: more tweaks, I think I want to make this into a role X-Git-Tag: 0.18_01~92 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d26633fcee47dfa1bc7349c67f7a586febf50f7a;p=gitmo%2FMooseX-AttributeHelpers.git more tweaks, I think I want to make this into a role --- diff --git a/lib/MooseX/AttributeHelpers/Base.pm b/lib/MooseX/AttributeHelpers/Base.pm new file mode 100644 index 0000000..452fd4b --- /dev/null +++ b/lib/MooseX/AttributeHelpers/Base.pm @@ -0,0 +1,101 @@ + +package MooseX::AttributeHelpers::Base; +use Moose; + +our $VERSION = '0.01'; +our $AUTHORITY = 'cpan:STEVAN'; + +extends 'Moose::Meta::Attribute'; + +has 'method_constructors' => ( + is => 'ro', + isa => 'HashRef', + default => sub { {} } +); + +has 'provides' => ( + is => 'ro', + isa => 'HashRef', + required => 1, +); + +has '+$!default' => (required => 1); +has '+type_constraint' => (required => 1); + +sub _check_provides { + my ($self, $provides) = @_; + my $method_constructors = $self->method_constructors; + foreach my $key (keys %$provides) { + (exists $method_constructors->{$key}) + || confess "$key is an unsupported method type"; + } +} + +sub _process_options_for_provides { + my ($self, $options) = @_; + # ... +} + +before '_process_options' => sub { + my ($self, %options) = @_; + + if (exists $options{provides}) { + $self->_check_provides($options{provides}); + $self->_process_options_for_provides(\%options); + } +}; + +after 'install_accessors' => sub { + my $attr = shift; + my $class = $attr->associated_class; + + my $method_constructors = $attr->method_constructors; + + foreach my $key (keys %{$attr->provides}) { + $class->add_method( + $attr->provides->{$key}, + $method_constructors->{$key}->($attr) + ); + } +}; + +no Moose; +no Moose::Util::TypeConstraints; + + +1; + +__END__ + +=pod + +=head1 NAME + +MooseX::AttributeHelpers::Base + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head1 METHODS + +=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 \ No newline at end of file diff --git a/lib/MooseX/AttributeHelpers/Collection/Array.pm b/lib/MooseX/AttributeHelpers/Collection/Array.pm index fc46ebb..043b035 100644 --- a/lib/MooseX/AttributeHelpers/Collection/Array.pm +++ b/lib/MooseX/AttributeHelpers/Collection/Array.pm @@ -1,88 +1,70 @@ package MooseX::AttributeHelpers::Collection::Array; use Moose; -use Moose::Util::TypeConstraints; our $VERSION = '0.01'; our $AUTHORITY = 'cpan:STEVAN'; -extends 'Moose::Meta::Attribute'; - -my %METHOD_CONSTRUCTORS = ( - 'push' => sub { - my $attr = shift; - return sub { - my $instance = shift; - push @{$attr->get_value($instance)} => @_; - }; - }, - 'pop' => sub { - my $attr = shift; - return sub { pop @{$attr->get_value($_[0])} }; - }, - 'unshift' => sub { - my $attr = shift; - return sub { - my $instance = shift; - unshift @{$attr->get_value($instance)} => @_; - }; - }, - 'shift' => sub { - my $attr = shift; - return sub { shift @{$attr->get_value($_[0])} }; - }, - 'get' => sub { - my $attr = shift; - return sub { $attr->get_value($_[0])->[$_[1]] }; - }, - 'set' => sub { - my $attr = shift; - return sub { $attr->get_value($_[0])->[$_[1]] = $_[2] }; - }, -); - -has 'provides' => ( - is => 'ro', - isa => subtype('HashRef' => where { - (exists $METHOD_CONSTRUCTORS{$_} || return) for keys %{$_}; 1; - }), - required => 1, +extends 'MooseX::AttributeHelpers::Base'; + +has '+method_constructors' => ( + default => sub { + return +{ + 'push' => sub { + my $attr = shift; + return sub { + my $instance = shift; + push @{$attr->get_value($instance)} => @_; + }; + }, + 'pop' => sub { + my $attr = shift; + return sub { pop @{$attr->get_value($_[0])} }; + }, + 'unshift' => sub { + my $attr = shift; + return sub { + my $instance = shift; + unshift @{$attr->get_value($instance)} => @_; + }; + }, + 'shift' => sub { + my $attr = shift; + return sub { shift @{$attr->get_value($_[0])} }; + }, + 'get' => sub { + my $attr = shift; + return sub { $attr->get_value($_[0])->[$_[1]] }; + }, + 'set' => sub { + my $attr = shift; + return sub { $attr->get_value($_[0])->[$_[1]] = $_[2] }; + }, + 'count' => sub { + my $attr = shift; + return sub { scalar @{$attr->get_value($_[0])} }; + }, + 'empty' => sub { + my $attr = shift; + return sub { scalar @{$attr->get_value($_[0])} ? 1 : 0 }; + } + } + } ); -has '+$!default' => (required => 1); -has '+type_constraint' => (required => 1); - -before '_process_options' => sub { - my ($self, %options) = @_; - - if (exists $options{provides}) { - (exists $options{isa}) - || confess "You must define a type with the Array metaclass"; - - (find_type_constraint($options{isa})->is_subtype_of('ArrayRef')) - || confess "The type constraint for a Array must be a subtype of ArrayRef"; - } -}; - -after 'install_accessors' => sub { - my $attr = shift; - my $class = $attr->associated_class; - - foreach my $key (keys %{$attr->provides}) { - (exists $METHOD_CONSTRUCTORS{$key}) - || confess "Unsupported method type ($key)"; - $class->add_method( - $attr->provides->{$key}, - $METHOD_CONSTRUCTORS{$key}->($attr) - ); - } -}; +sub _process_options_for_provides { + my ($self, $options) = @_; + (exists $options->{isa}) + || confess "You must define a type with the Array metaclass"; + + (find_type_constraint($options->{isa})->is_subtype_of('ArrayRef')) + || confess "The type constraint for a Array must be a subtype of ArrayRef"; +} no Moose; -no Moose::Util::TypeConstraints; # register the alias ... -package Moose::Meta::Attribute::Custom::Collection; +package Moose::Meta::Attribute::Custom::Collection::Array; sub register_implementation { 'MooseX::AttributeHelpers::Collection::Array' } diff --git a/lib/MooseX/AttributeHelpers/Collection/Hash.pm b/lib/MooseX/AttributeHelpers/Collection/Hash.pm index fa52a76..c80cedc 100644 --- a/lib/MooseX/AttributeHelpers/Collection/Hash.pm +++ b/lib/MooseX/AttributeHelpers/Collection/Hash.pm @@ -1,9 +1,51 @@ package MooseX::AttributeHelpers::Collection::Hash; +use Moose; our $VERSION = '0.01'; our $AUTHORITY = 'cpan:STEVAN'; +extends 'MooseX::AttributeHelpers::Base'; + +has '+method_constructors' => ( + default => sub { + return +{ + 'get' => sub { + my $attr = shift; + return sub { $attr->get_value($_[0])->{$_[1]} }; + }, + 'set' => sub { + my $attr = shift; + return sub { $attr->get_value($_[0])->{$_[1]} = $_[2] }; + }, + 'count' => sub { + my $attr = shift; + return sub { scalar keys %{$attr->get_value($_[0])} }; + }, + 'empty' => sub { + my $attr = shift; + return sub { scalar keys %{$attr->get_value($_[0])} ? 1 : 0 }; + } + } + } +); + +sub _process_options_for_provides { + my ($self, $options) = @_; + (exists $options->{isa}) + || confess "You must define a type with the Hash metaclass"; + + (find_type_constraint($options->{isa})->is_subtype_of('HashRef')) + || confess "The type constraint for a Hash must be a subtype of HashRef"; +} + +no Moose; + +# register the alias ... +package Moose::Meta::Attribute::Custom::Collection::Hash; +sub register_implementation { 'MooseX::AttributeHelpers::Collection::Hash' } + + 1; __END__ diff --git a/lib/MooseX/AttributeHelpers/Counter.pm b/lib/MooseX/AttributeHelpers/Counter.pm index 3bce3b0..83ede3b 100644 --- a/lib/MooseX/AttributeHelpers/Counter.pm +++ b/lib/MooseX/AttributeHelpers/Counter.pm @@ -1,63 +1,37 @@ package MooseX::AttributeHelpers::Counter; use Moose; -use Moose::Util::TypeConstraints; our $VERSION = '0.01'; our $AUTHORITY = 'cpan:STEVAN'; -extends 'Moose::Meta::Attribute'; - -my %METHOD_CONSTRUCTORS = ( - inc => sub { - my $attr = shift; - return sub { $attr->set_value($_[0], $attr->get_value($_[0]) + 1) }; - }, - dec => sub { - my $attr = shift; - return sub { $attr->set_value($_[0], $attr->get_value($_[0]) - 1) }; - }, -); - -has 'provides' => ( - is => 'ro', - isa => subtype('HashRef' => where { - (exists $METHOD_CONSTRUCTORS{$_} || return) for keys %{$_}; 1; - }), - required => 1, -); - -has '+$!default' => (required => 1); -has '+type_constraint' => (required => 1); - -before '_process_options' => sub { - my ($self, %options) = @_; - - if (exists $options{provides}) { - (exists $options{isa}) - || confess "You must define a type with the Counter metaclass"; - - (find_type_constraint($options{isa})->is_subtype_of('Num')) - || confess "The type constraint for a Counter must be a subtype of Num"; +extends 'MooseX::AttributeHelpers::Base'; + +has '+method_constructors' => ( + default => sub { + return +{ + inc => sub { + my $attr = shift; + return sub { $attr->set_value($_[0], $attr->get_value($_[0]) + 1) }; + }, + dec => sub { + my $attr = shift; + return sub { $attr->set_value($_[0], $attr->get_value($_[0]) - 1) }; + }, + } } -}; +); -after 'install_accessors' => sub { - my $attr = shift; - my $class = $attr->associated_class; +sub _process_options_for_provides { + my ($self, $options) = @_; + (exists $options->{isa}) + || confess "You must define a type with the Counter metaclass"; + + (find_type_constraint($options->{isa})->is_subtype_of('Num')) + || confess "The type constraint for a Counter must be a subtype of Num"; +} - foreach my $key (keys %{$attr->provides}) { - (exists $METHOD_CONSTRUCTORS{$key}) - || confess "Unsupported method type ($key)"; - $class->add_method( - $attr->provides->{$key}, - $METHOD_CONSTRUCTORS{$key}->($attr) - ); - } -}; - no Moose; -no Moose::Util::TypeConstraints; # register the alias ... package Moose::Meta::Attribute::Custom::Counter; diff --git a/t/002_basic_collection.t b/t/002_basic_collection.t index b785864..f0ebb98 100644 --- a/t/002_basic_collection.t +++ b/t/002_basic_collection.t @@ -14,7 +14,7 @@ BEGIN { use Moose; has 'options' => ( - metaclass => 'Collection', + metaclass => 'Collection::Array', is => 'ro', isa => 'ArrayRef', default => sub { [] }, diff --git a/t/003_basic_hash.t b/t/003_basic_hash.t new file mode 100644 index 0000000..7f784df --- /dev/null +++ b/t/003_basic_hash.t @@ -0,0 +1,42 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More no_plan => 1; + +BEGIN { + use_ok('MooseX::AttributeHelpers'); +} + +{ + package Stuff; + use Moose; + + has 'options' => ( + metaclass => 'Collection::Hash', + is => 'ro', + isa => 'HashRef', + default => sub { {} }, + provides => { + 'set' => 'set_option', + 'get' => 'get_option', + } + ); +} + +my $stuff = Stuff->new(); +isa_ok($stuff, 'Stuff'); + +is_deeply($stuff->options, {}, '... no options yet'); + +$stuff->set_option(foo => 'bar'); +is_deeply($stuff->options, { foo => 'bar' }, '... got options now'); + +$stuff->set_option(bar => 'baz'); +is_deeply($stuff->options, { foo => 'bar', bar => 'baz' }, '... got more options now'); + +is($stuff->get_option('foo'), 'bar', '... got the right option'); + + +