X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FAttributeHelpers%2FBase.pm;h=4d40a0f8c5d889bb5946578625b6ab2cbf710193;hb=999f34a9f1cec59b0ae02921559732d1885051c5;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..4d40a0f 100644 --- a/lib/MooseX/AttributeHelpers/Base.pm +++ b/lib/MooseX/AttributeHelpers/Base.pm @@ -1,72 +1,151 @@ package MooseX::AttributeHelpers::Base; use Moose; +use Moose::Util::TypeConstraints; -our $VERSION = '0.01'; +our $VERSION = '0.04'; 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, + +# 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 -# all valid possibilities in it -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"; - } -} +## Methods called prior to instantiation -# this provides an opportunity to -# manipulate the %options to handle -# some of the provides features -# correctly. -sub _process_options_for_provides { +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, %options) = @_; - if (exists $options{provides}) { - $self->_check_provides($options{provides}); - $self->_process_options_for_provides(\%options); - } + my ($self, $name, $options) = @_; + $self->process_options_for_provides($options, $name); }; +## methods called after instantiation + +# this confirms that provides 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"; + } +} + 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; - + 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, + ) ); + + $attr->associate_method($method); + $class->add_method($method_name => $method); + } +}; + +after 'remove_accessors' => sub { + my $attr = shift; + my $class = $attr->associated_class; + 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'); } }; no Moose; +no Moose::Util::TypeConstraints; 1; @@ -76,17 +155,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. @@ -103,4 +230,4 @@ 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