X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FAttributeHelpers%2FTrait%2FBase.pm;h=4294e77c9854d9895e709340c689e0175833b301;hb=1b8bf95af999733ebc55c7ab22d3e46bed1fb805;hp=6da6eae57431137c633ebf48540432c96528cd65;hpb=dbd51f3079bc5debaa79062c558ac4f47e8d374b;p=gitmo%2FMooseX-AttributeHelpers.git

diff --git a/lib/MooseX/AttributeHelpers/Trait/Base.pm b/lib/MooseX/AttributeHelpers/Trait/Base.pm
index 6da6eae..4294e77 100644
--- a/lib/MooseX/AttributeHelpers/Trait/Base.pm
+++ b/lib/MooseX/AttributeHelpers/Trait/Base.pm
@@ -3,7 +3,8 @@ package MooseX::AttributeHelpers::Trait::Base;
 use Moose::Role;
 use Moose::Util::TypeConstraints;
 
-our $VERSION   = '0.04';
+our $VERSION   = '0.21';
+$VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';
 
 requires 'helper_type';
@@ -15,6 +16,11 @@ 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.
@@ -39,14 +45,15 @@ has 'method_constructors' => (
         return +{
             map {
                 $_ => $method_provider->get_method($_)
-            } $method_provider->get_method_list
+            }
+            grep { $_ ne 'meta' } $method_provider->get_method_list
         };
     },
 );
 
 # extend the parents stuff to make sure
 # certain bits are now required ...
-has '+$!default'       => (required => 1);
+has '+default'         => (required => 1);
 has '+type_constraint' => (required => 1);
 
 ## Methods called prior to instantiation
@@ -76,8 +83,6 @@ before '_process_options' => sub {
 
 ## methods called after instantiation
 
-# this confirms that provides has
-# all valid possibilities in it
 sub check_provides_values {
     my $self = shift;
 
@@ -87,6 +92,33 @@ sub check_provides_values {
         (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 {
@@ -108,6 +140,41 @@ after 'install_accessors' => sub {
 
     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 ARRAY 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};
@@ -134,6 +201,8 @@ after 'install_accessors' => sub {
 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);
@@ -141,6 +210,15 @@ after 'remove_accessors' => sub {
             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::Role;
@@ -148,3 +226,43 @@ no Moose::Util::TypeConstraints;
 
 1;
 
+__END__
+
+=head1 NAME
+
+MooseX::AttributeHelpers::Trait::Base - base role for helpers
+
+=head1 METHODS
+
+=head2 check_provides_values
+
+Confirms that provides (and curries) has all valid possibilities in it.
+
+=head2 process_options_for_provides
+
+Ensures that the type constraint (C<isa>) matches the helper type.
+
+=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 AUTHORS
+
+Yuval Kogman
+
+Shawn M Moore
+
+Jesse Luehrs
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007-2009 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut