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=0c52869fc1564adc10681afa0f8a14641dc81fb6;hpb=8881a8d37b7aea1ca7f0852c1b6120872e378409;p=gitmo%2FMooseX-AttributeHelpers.git diff --git a/lib/MooseX/AttributeHelpers/Base.pm b/lib/MooseX/AttributeHelpers/Base.pm index 0c52869..4709e3a 100644 --- a/lib/MooseX/AttributeHelpers/Base.pm +++ b/lib/MooseX/AttributeHelpers/Base.pm @@ -1,72 +1,234 @@ 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); -# this confirms that provides has +## Methods called prior to instantiation + +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"; + + my $isa = $options->{isa}; + + unless (blessed($isa) && $isa->isa('Moose::Meta::TypeConstraint')) { + $isa = Moose::Util::TypeConstraints::find_or_create_type_constraint($isa); + } + + ($isa->is_a_type_of($type)) + || confess "The type constraint for a $type ($options->{isa}) must be a subtype of $type"; + } +} + +before '_process_options' => sub { + my ($self, $name, $options) = @_; + $self->process_options_for_provides($options, $name); +}; + +## methods called after instantiation + +# this confirms that provides (and curries) has # all valid possibilities in it -sub _check_provides { - my ($self, $provides) = @_; +sub check_provides_values { + my $self = shift; + my $method_constructors = $self->method_constructors; - foreach my $key (keys %$provides) { + + 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"; } } -# this provides an opportunity to -# manipulate the %options to handle -# some of the provides features -# correctly. -sub _process_options_for_provides { - my ($self, $options) = @_; - # ... +sub _curry { + my $self = shift; + my $code = shift; + + my @args = @_; + return sub { + my $self = shift; + $code->($self, @args, @_) + }; } -before '_process_options' => sub { - my ($self, %options) = @_; - if (exists $options{provides}) { - $self->_check_provides($options{provides}); - $self->_process_options_for_provides(\%options); - } -}; +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; + 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}) { - $class->add_method( - $attr->provides->{$key}, - $method_constructors->{$key}->($attr) + + my $method_name = $attr->provides->{$key}; + + if ($class->has_method($method_name)) { + confess "The method ($method_name) already exists in class (" . $class->name . ")"; + } + + 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'); } }; no Moose; +no Moose::Util::TypeConstraints; 1; @@ -76,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. @@ -96,11 +306,11 @@ Stevan Little Estevan@iinteractive.comE =head1 COPYRIGHT AND LICENSE -Copyright 2007 by Infinity Interactive, Inc. +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 \ No newline at end of file +=cut