X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FAttributeHelpers%2FBase.pm;h=4709e3a2d2dd5c653f4d50abeada503a4871b854;hb=18d43c2c0d8aca2fd61b44cfc0a041788616895f;hp=533c083ace8eba25b89eb4683a449a3d26dbd26c;hpb=8f7951c9a2ef1fb01d8e04e277df1099102fedf8;p=gitmo%2FMooseX-AttributeHelpers.git diff --git a/lib/MooseX/AttributeHelpers/Base.pm b/lib/MooseX/AttributeHelpers/Base.pm index 533c083..4709e3a 100644 --- a/lib/MooseX/AttributeHelpers/Base.pm +++ b/lib/MooseX/AttributeHelpers/Base.pm @@ -3,24 +3,57 @@ package MooseX::AttributeHelpers::Base; use Moose; use Moose::Util::TypeConstraints; -our $VERSION = '0.01'; +our $VERSION = '0.13'; our $AUTHORITY = 'cpan:STEVAN'; extends 'Moose::Meta::Attribute'; -has 'method_constructors' => ( +# this is the method map you define ... +has 'provides' => ( is => 'ro', isa => 'HashRef', - default => sub { {} } + default => sub {{}} ); -has 'provides' => ( - is => 'ro', - isa => 'HashRef', - required => 1, +has 'curries' => ( + is => 'ro', + isa => 'HashRef', + default => sub {{}} +); + + +# these next two are the possible methods +# you can use in the 'provides' map. + +# provide a Class or Role which we can +# collect the method providers from +has 'method_provider' => ( + is => 'ro', + isa => 'ClassName', + predicate => 'has_method_provider', +); + +# or you can provide a HASH ref of anon subs +# yourself. This will also collect and store +# the methods from a method_provider as well +has 'method_constructors' => ( + is => 'ro', + isa => 'HashRef', + lazy => 1, + default => sub { + my $self = shift; + return +{} unless $self->has_method_provider; + # or grab them from the role/class + my $method_provider = $self->method_provider->meta; + return +{ + map { + $_ => $method_provider->get_method($_) + } $method_provider->get_method_list + }; + }, ); -# extend the parents stuff to make sure +# extend the parents stuff to make sure # certain bits are now required ... has '+$!default' => (required => 1); has '+type_constraint' => (required => 1); @@ -31,15 +64,15 @@ sub helper_type { () } sub process_options_for_provides { my ($self, $options) = @_; - + if (my $type = $self->helper_type) { (exists $options->{isa}) - || confess "You must define a type with the $type metaclass"; + || confess "You must define a type with the $type metaclass"; - my $isa = $options->{isa}; + my $isa = $options->{isa}; unless (blessed($isa) && $isa->isa('Moose::Meta::TypeConstraint')) { - $isa = find_type_constraint($isa); + $isa = Moose::Util::TypeConstraints::find_or_create_type_constraint($isa); } ($isa->is_a_type_of($type)) @@ -49,48 +82,148 @@ sub process_options_for_provides { before '_process_options' => sub { my ($self, $name, $options) = @_; - if (exists $options->{provides}) { - $self->process_options_for_provides($options); - } + $self->process_options_for_provides($options, $name); }; ## methods called after instantiation -# this confirms that provides has +# this confirms that provides (and curries) has # all valid possibilities in it sub check_provides_values { my $self = shift; + my $method_constructors = $self->method_constructors; + foreach my $key (keys %{$self->provides}) { (exists $method_constructors->{$key}) || confess "$key is an unsupported method type"; } + + foreach my $key (keys %{$self->curries}) { + (exists $method_constructors->{$key}) + || confess "$key is an unsupported method type"; + } +} + +sub _curry { + my $self = shift; + my $code = shift; + + my @args = @_; + return sub { + my $self = shift; + $code->($self, @args, @_) + }; +} + +sub _curry_sub { + my $self = shift; + my $body = shift; + my $code = shift; + + return sub { + my $self = shift; + $code->($self, $body, @_) + }; } 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->get_read_method_ref; + my $attr_writer = $attr->get_write_method_ref; + + # before we install them, lets # make sure they are valid - $attr->check_provides_values; + $attr->check_provides_values; my $method_constructors = $attr->method_constructors; - + + my $class_name = $class->name; + + while (my ($constructor, $constructed) = each %{$attr->curries}) { + my $method_code; + while (my ($curried_name, $curried_arg) = each(%$constructed)) { + if ($class->has_method($curried_name)) { + confess + "The method ($curried_name) already ". + "exists in class (" . $class->name . ")"; + } + my $body = $method_constructors->{$constructor}->( + $attr, + $attr_reader, + $attr_writer, + ); + + if (ref $curried_arg eq 'ARRAY') { + $method_code = $attr->_curry($body, @$curried_arg); + } + elsif (ref $curried_arg eq 'CODE') { + $method_code = $attr->_curry_sub($body, $curried_arg); + } + else { + confess "curries parameter must be ref type HASH or CODE"; + } + + my $method = MooseX::AttributeHelpers::Meta::Method::Curried->wrap( + $method_code, + package_name => $class_name, + name => $curried_name, + ); + + $attr->associate_method($method); + $class->add_method($curried_name => $method); + } + } + foreach my $key (keys %{$attr->provides}) { - + my $method_name = $attr->provides->{$key}; - my $method_body = $method_constructors->{$key}->($attr); - + if ($class->has_method($method_name)) { confess "The method ($method_name) already exists in class (" . $class->name . ")"; } - - $class->add_method($method_name => - MooseX::AttributeHelpers::Meta::Method::Provided->wrap( - $method_body, - ) + + my $method = MooseX::AttributeHelpers::Meta::Method::Provided->wrap( + $method_constructors->{$key}->( + $attr, + $attr_reader, + $attr_writer, + ), + package_name => $class_name, + name => $method_name, ); + + $attr->associate_method($method); + $class->add_method($method_name => $method); + } +}; + +after 'remove_accessors' => sub { + my $attr = shift; + my $class = $attr->associated_class; + + # provides accessors + foreach my $key (keys %{$attr->provides}) { + my $method_name = $attr->provides->{$key}; + my $method = $class->get_method($method_name); + $class->remove_method($method_name) + if blessed($method) && + $method->isa('MooseX::AttributeHelpers::Meta::Method::Provided'); + } + + # curries accessors + foreach my $key (keys %{$attr->curries}) { + my $method_name = $attr->curries->{$key}; + my $method = $class->get_method($method_name); + $class->remove_method($method_name) + if blessed($method) && + $method->isa('MooseX::AttributeHelpers::Meta::Method::Provided'); } }; @@ -105,17 +238,65 @@ __END__ =head1 NAME -MooseX::AttributeHelpers::Base +MooseX::AttributeHelpers::Base - Base class for attribute helpers -=head1 SYNOPSIS - =head1 DESCRIPTION +Documentation to come. + +=head1 ATTRIBUTES + +=over 4 + +=item B + +=item B + +=item B + +=back + +=head1 EXTENDED ATTRIBUTES + +=over 4 + +=item B<$!default> + +C<$!default> is now required. + +=item B + +C is now required. + +=back + =head1 METHODS +=over 4 + +=item B + +=item B + +=item B + +=item B + +=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 +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. @@ -125,7 +306,7 @@ Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE -Copyright 2007 by Infinity Interactive, Inc. +Copyright 2007-2008 by Infinity Interactive, Inc. L