lib/MooseX/AttributeHelpers/Trait/Base.pm

   1
   2 package MooseX::AttributeHelpers::Trait::Base;
   3 use Moose::Role;
   4 use Moose::Util::TypeConstraints;
   5
   6 our $VERSION   = '0.22';
   7 $VERSION = eval $VERSION;
   8 our $AUTHORITY = 'cpan:STEVAN';
   9
  10 requires 'helper_type';
  11
  12 # this is the method map you define ...
  13 has 'provides' => (
  14     is      => 'ro',
  15     isa     => 'HashRef',
  16     default => sub {{}}
  17 );
  18
  19 has 'curries' => (
  20     is      => 'ro',
  21     isa     => 'HashRef',
  22     default => sub {{}}
  23 );
  24
  25 # these next two are the possible methods
  26 # you can use in the 'provides' map.
  27
  28 # provide a Class or Role which we can
  29 # collect the method providers from
  30
  31 # requires_attr 'method_provider'
  32
  33 # or you can provide a HASH ref of anon subs
  34 # yourself. This will also collect and store
  35 # the methods from a method_provider as well
  36 has 'method_constructors' => (
  37     is      => 'ro',
  38     isa     => 'HashRef',
  39     lazy    => 1,
  40     default => sub {
  41         my $self = shift;
  42         return +{} unless $self->has_method_provider;
  43         # or grab them from the role/class
  44         my $method_provider = $self->method_provider->meta;
  45         return +{
  46             map {
  47                 $_ => $method_provider->get_method($_)
  48             }
  49             grep { $_ ne 'meta' } $method_provider->get_method_list
  50         };
  51     },
  52 );
  53
  54 # extend the parents stuff to make sure
  55 # certain bits are now required ...
  56 has '+default'         => (required => 1);
  57 has '+type_constraint' => (required => 1);
  58
  59 ## Methods called prior to instantiation
  60
  61 sub process_options_for_provides {
  62     my ($self, $options) = @_;
  63
  64     if (my $type = $self->helper_type) {
  65         (exists $options->{isa})
  66             || confess "You must define a type with the $type metaclass";
  67
  68         my $isa = $options->{isa};
  69
  70         unless (blessed($isa) && $isa->isa('Moose::Meta::TypeConstraint')) {
  71             $isa = Moose::Util::TypeConstraints::find_or_create_type_constraint($isa);
  72         }
  73
  74         ($isa->is_a_type_of($type))
  75             || confess "The type constraint for a $type ($options->{isa}) must be a subtype of $type";
  76     }
  77 }
  78
  79 before '_process_options' => sub {
  80     my ($self, $name, $options) = @_;
  81     $self->process_options_for_provides($options, $name);
  82 };
  83
  84 ## methods called after instantiation
  85
  86 sub check_provides_values {
  87     my $self = shift;
  88
  89     my $method_constructors = $self->method_constructors;
  90
  91     foreach my $key (keys %{$self->provides}) {
  92         (exists $method_constructors->{$key})
  93             || confess "$key is an unsupported method type";
  94     }
  95
  96     foreach my $key (keys %{$self->curries}) {
  97         (exists $method_constructors->{$key})
  98             || confess "$key is an unsupported method type";
  99     }
 100 }
 101
 102 sub _curry {
 103     my $self = shift;
 104     my $code = shift;
 105
 106     my @args = @_;
 107     return sub {
 108         my $self = shift;
 109         $code->($self, @args, @_)
 110     };
 111 }
 112
 113 sub _curry_sub {
 114     my $self = shift;
 115     my $body = shift;
 116     my $code = shift;
 117
 118     return sub {
 119         my $self = shift;
 120         $code->($self, $body, @_)
 121     };
 122 }
 123
 124 after 'install_accessors' => sub {
 125     my $attr  = shift;
 126     my $class = $attr->associated_class;
 127
 128     # grab the reader and writer methods
 129     # as well, this will be useful for
 130     # our method provider constructors
 131     my $attr_reader = $attr->get_read_method_ref;
 132     my $attr_writer = $attr->get_write_method_ref;
 133
 134
 135     # before we install them, lets
 136     # make sure they are valid
 137     $attr->check_provides_values;
 138
 139     my $method_constructors = $attr->method_constructors;
 140
 141     my $class_name = $class->name;
 142
 143     while (my ($constructor, $constructed) = each %{$attr->curries}) {
 144         my $method_code;
 145         while (my ($curried_name, $curried_arg) = each(%$constructed)) {
 146             if ($class->has_method($curried_name)) {
 147                 confess
 148                     "The method ($curried_name) already ".
 149                     "exists in class (" . $class->name . ")";
 150             }
 151             my $body = $method_constructors->{$constructor}->(
 152                        $attr,
 153                        $attr_reader,
 154                        $attr_writer,
 155             );
 156
 157             if (ref $curried_arg eq 'ARRAY') {
 158                 $method_code = $attr->_curry($body, @$curried_arg);
 159             }
 160             elsif (ref $curried_arg eq 'CODE') {
 161                 $method_code = $attr->_curry_sub($body, $curried_arg);
 162             }
 163             else {
 164                 confess "curries parameter must be ref type ARRAY or CODE";
 165             }
 166
 167             my $method = MooseX::AttributeHelpers::Meta::Method::Curried->wrap(
 168                 $method_code,
 169                 package_name => $class_name,
 170                 name => $curried_name,
 171             );
 172
 173             $attr->associate_method($method);
 174             $class->add_method($curried_name => $method);
 175         }
 176     }
 177
 178     foreach my $key (keys %{$attr->provides}) {
 179
 180         my $method_name = $attr->provides->{$key};
 181
 182         if ($class->has_method($method_name)) {
 183             confess "The method ($method_name) already exists in class (" . $class->name . ")";
 184         }
 185
 186         my $method = MooseX::AttributeHelpers::Meta::Method::Provided->wrap(
 187             $method_constructors->{$key}->(
 188                 $attr,
 189                 $attr_reader,
 190                 $attr_writer,
 191             ),
 192             package_name => $class_name,
 193             name => $method_name,
 194         );
 195
 196         $attr->associate_method($method);
 197         $class->add_method($method_name => $method);
 198     }
 199 };
 200
 201 after 'remove_accessors' => sub {
 202     my $attr  = shift;
 203     my $class = $attr->associated_class;
 204
 205     # provides accessors
 206     foreach my $key (keys %{$attr->provides}) {
 207         my $method_name = $attr->provides->{$key};
 208         my $method = $class->get_method($method_name);
 209         $class->remove_method($method_name)
 210             if blessed($method) &&
 211                $method->isa('MooseX::AttributeHelpers::Meta::Method::Provided');
 212     }
 213
 214     # curries accessors
 215     foreach my $key (keys %{$attr->curries}) {
 216         my $method_name = $attr->curries->{$key};
 217         my $method = $class->get_method($method_name);
 218         $class->remove_method($method_name)
 219             if blessed($method) &&
 220                $method->isa('MooseX::AttributeHelpers::Meta::Method::Provided');
 221     }
 222 };
 223
 224 no Moose::Role;
 225 no Moose::Util::TypeConstraints;
 226
 227 1;
 228
 229 __END__
 230
 231 =head1 NAME
 232
 233 MooseX::AttributeHelpers::Trait::Base - base role for helpers
 234
 235 =head1 METHODS
 236
 237 =head2 check_provides_values
 238
 239 Confirms that provides (and curries) has all valid possibilities in it.
 240
 241 =head2 process_options_for_provides
 242
 243 Ensures that the type constraint (C<isa>) matches the helper type.
 244
 245 =head1 BUGS
 246
 247 All complex software has bugs lurking in it, and this module is no
 248 exception. If you find a bug please either email me, or add the bug
 249 to cpan-RT.
 250
 251 =head1 AUTHORS
 252
 253 Yuval Kogman
 254
 255 Shawn M Moore
 256
 257 Jesse Luehrs
 258
 259 =head1 COPYRIGHT AND LICENSE
 260
 261 Copyright 2007-2009 by Infinity Interactive, Inc.
 262
 263 L<http://www.iinteractive.com>
 264
 265 This library is free software; you can redistribute it and/or modify
 266 it under the same terms as Perl itself.
 267
 268 =cut