lib/Moose/AttributeHelpers/Trait/Base.pm

   1
   2 package Moose::AttributeHelpers::Trait::Base;
   3 use Moose::Role;
   4 use Moose::Util::TypeConstraints;
   5 use Moose::AttributeHelpers::Meta::Method::Delegation;
   6
   7 our $VERSION   = '0.19';
   8 $VERSION = eval $VERSION;
   9 our $AUTHORITY = 'cpan:STEVAN';
  10
  11 requires 'helper_type';
  12
  13 # these next two are the possible methods
  14 # you can use in the 'handles' map.
  15
  16 # provide a Class or Role which we can
  17 # collect the method providers from
  18
  19 # requires_attr 'method_provider'
  20
  21 # or you can provide a HASH ref of anon subs
  22 # yourself. This will also collect and store
  23 # the methods from a method_provider as well
  24 has 'method_constructors' => (
  25     is      => 'ro',
  26     isa     => 'HashRef',
  27     lazy    => 1,
  28     default => sub {
  29         my $self = shift;
  30         return +{} unless $self->has_method_provider;
  31         # or grab them from the role/class
  32         my $method_provider = $self->method_provider->meta;
  33         return +{
  34             map {
  35                 $_ => $method_provider->get_method($_)
  36             } $method_provider->get_method_list
  37         };
  38     },
  39 );
  40
  41 # extend the parents stuff to make sure
  42 # certain bits are now required ...
  43 has '+default'         => (required => 1);
  44 has '+type_constraint' => (required => 1);
  45
  46 ## Methods called prior to instantiation
  47
  48 sub process_options_for_handles {
  49     my ($self, $options) = @_;
  50
  51     if (my $type = $self->helper_type) {
  52         (exists $options->{isa})
  53             || confess "You must define a type with the $type metaclass";
  54
  55         my $isa = $options->{isa};
  56
  57         unless (blessed($isa) && $isa->isa('Moose::Meta::TypeConstraint')) {
  58             $isa = Moose::Util::TypeConstraints::find_or_create_type_constraint($isa);
  59         }
  60
  61         ($isa->is_a_type_of($type))
  62             || confess "The type constraint for a $type ($options->{isa}) must be a subtype of $type";
  63     }
  64 }
  65
  66 sub delegation_metaclass {
  67     'Moose::AttributeHelpers::Meta::Method::Delegation'
  68 }
  69
  70 before '_process_options' => sub {
  71     my ($self, $name, $options) = @_;
  72     $self->process_options_for_handles($options, $name);
  73 };
  74
  75 around '_canonicalize_handles' => sub {
  76     my $next    = shift;
  77     my $self    = shift;
  78     my $handles = $self->handles;
  79     return unless $handles;
  80     unless ('HASH' eq ref $handles) {
  81         $self->throw_error(
  82             "The 'handles' option must be a HASH reference, not $handles"
  83         );
  84     }
  85     return map {
  86         my $to = $handles->{$_};
  87         $to = [ $to ] unless ref $to;
  88         $_ => $to
  89     } keys %$handles;
  90 };
  91
  92 ## methods called after instantiation
  93
  94 before 'install_delegation' => sub { (shift)->check_handles_values };
  95
  96 sub check_handles_values {
  97     my $self = shift;
  98
  99     my $method_constructors = $self->method_constructors;
 100
 101     my %handles = $self->_canonicalize_handles;
 102
 103     for my $original_method (values %handles) {
 104         my $name = $original_method->[0];
 105         (exists $method_constructors->{$name})
 106             || confess "$name is an unsupported method type";
 107     }
 108
 109 }
 110
 111 no Moose::Role;
 112 no Moose::Util::TypeConstraints;
 113
 114 1;
 115
 116 __END__
 117
 118 =head1 NAME
 119
 120 Moose::AttributeHelpers::Trait::Base - base role for helpers
 121
 122 =head1 METHODS
 123
 124 =head2 check_handles_values
 125
 126 Confirms that handles has all valid possibilities in it.
 127
 128 =head2 process_options_for_handles
 129
 130 Ensures that the type constraint (C<isa>) matches the helper type.
 131
 132 =head1 BUGS
 133
 134 All complex software has bugs lurking in it, and this module is no
 135 exception. If you find a bug please either email me, or add the bug
 136 to cpan-RT.
 137
 138 =head1 AUTHORS
 139
 140 Yuval Kogman
 141
 142 Shawn M Moore
 143
 144 Jesse Luehrs
 145
 146 =head1 COPYRIGHT AND LICENSE
 147
 148 Copyright 2007-2009 by Infinity Interactive, Inc.
 149
 150 L<http://www.iinteractive.com>
 151
 152 This library is free software; you can redistribute it and/or modify
 153 it under the same terms as Perl itself.
 154
 155 =cut