lib/Moose/Meta/Attribute/Native/Trait.pm

   1
   2 package Moose::Meta::Attribute::Native::Trait;
   3 use Moose::Role;
   4
   5 use List::MoreUtils qw( any );
   6 use Moose::Util::TypeConstraints;
   7 use Moose::Deprecated;
   8
   9 our $VERSION   = '1.15';
  10 $VERSION = eval $VERSION;
  11 our $AUTHORITY = 'cpan:STEVAN';
  12
  13 requires '_helper_type';
  14
  15 before '_process_options' => sub {
  16     my ( $self, $name, $options ) = @_;
  17
  18     $self->_check_helper_type( $options, $name );
  19
  20     if ( !( any { exists $options->{$_} } qw( is reader writer accessor ) )
  21         && $self->can('_default_is') ) {
  22
  23         $options->{is} = $self->_default_is;
  24
  25         Moose::Deprecated::deprecated(
  26             feature => 'default is for Native Trait',
  27             message =>
  28                 q{Allowing a native trait to automatically supply a value for "is" is deprecated}
  29         );
  30     }
  31
  32     if (
  33         !(
  34             $options->{required}
  35             || any { exists $options->{$_} } qw( default builder )
  36         )
  37         && $self->can('_default_default')
  38         ) {
  39
  40         $options->{default} = $self->_default_default;
  41
  42         Moose::Deprecated::deprecated(
  43             feature => 'default default for Native Trait',
  44             message =>
  45                 'Allowing a native trait to automatically supply a default is deprecated'
  46         );
  47     }
  48 };
  49
  50 sub _check_helper_type {
  51     my ( $self, $options, $name ) = @_;
  52
  53     my $type = $self->_helper_type;
  54
  55     $options->{isa} = $type
  56         unless exists $options->{isa};
  57
  58     my $isa = Moose::Util::TypeConstraints::find_or_create_type_constraint(
  59         $options->{isa} );
  60
  61     ( $isa->is_a_type_of($type) )
  62         || confess
  63         "The type constraint for $name must be a subtype of $type but it's a $isa";
  64 }
  65
  66 before 'install_accessors' => sub { (shift)->_check_handles_values };
  67
  68 sub _check_handles_values {
  69     my $self = shift;
  70
  71     my %handles = $self->_canonicalize_handles;
  72
  73     for my $original_method ( values %handles ) {
  74         my $name = $original_method->[0];
  75
  76         my $accessor_class = $self->_native_accessor_class_for($name);
  77
  78         ( $accessor_class && $accessor_class->can('new') )
  79             || confess
  80             "$name is an unsupported method type - $accessor_class";
  81     }
  82 }
  83
  84 around '_canonicalize_handles' => sub {
  85     shift;
  86     my $self    = shift;
  87     my $handles = $self->handles;
  88
  89     return unless $handles;
  90
  91     unless ( 'HASH' eq ref $handles ) {
  92         $self->throw_error(
  93             "The 'handles' option must be a HASH reference, not $handles");
  94     }
  95
  96     return map {
  97         my $to = $handles->{$_};
  98         $to = [$to] unless ref $to;
  99         $_ => $to
 100     } keys %$handles;
 101 };
 102
 103 around '_make_delegation_method' => sub {
 104     my $next = shift;
 105     my ( $self, $handle_name, $method_to_call ) = @_;
 106
 107     my ( $name, @curried_args ) = @$method_to_call;
 108
 109     my $accessor_class = $self->_native_accessor_class_for($name);
 110
 111     die "Cannot find an accessor class for $name"
 112         unless $accessor_class && $accessor_class->can('new');
 113
 114     return $accessor_class->new(
 115         name               => $handle_name,
 116         package_name       => $self->associated_class->name,
 117         delegate_to_method => $name,
 118         attribute          => $self,
 119         is_inline          => 1,
 120         curried_arguments  => \@curried_args,
 121         root_types         => [ $self->_root_types ],
 122     );
 123 };
 124
 125 sub _root_types {
 126     return $_[0]->_helper_type;
 127 }
 128
 129 sub _native_accessor_class_for {
 130     my ( $self, $suffix ) = @_;
 131
 132     my $role
 133         = 'Moose::Meta::Method::Accessor::Native::'
 134         . $self->_native_type . '::'
 135         . $suffix;
 136
 137     return Moose::Meta::Class->create_anon_class(
 138         superclasses =>
 139             [ $self->accessor_metaclass, $self->delegation_metaclass ],
 140         roles => [$role],
 141         cache => 1,
 142     )->name;
 143 }
 144
 145 sub _build_native_type {
 146     my $self = shift;
 147
 148     for my $role_name ( map { $_->name } $self->meta->calculate_all_roles ) {
 149         return $1 if $role_name =~ /::Native::Trait::(\w+)$/;
 150     }
 151
 152     die "Cannot calculate native type for " . ref $self;
 153 }
 154
 155 has '_native_type' => (
 156     is      => 'ro',
 157     isa     => 'Str',
 158     lazy    => 1,
 159     builder => '_build_native_type',
 160 );
 161
 162 no Moose::Role;
 163 no Moose::Util::TypeConstraints;
 164
 165 1;
 166
 167 __END__
 168
 169 =head1 NAME
 170
 171 Moose::Meta::Attribute::Native::Trait - Shared role for native delegation traits
 172
 173 =head1 BUGS
 174
 175 See L<Moose/BUGS> for details on reporting bugs.
 176
 177 =head1 SEE ALSO
 178
 179 Documentation for Moose native traits can be found in
 180 L<Moose::Meta::Attribute::Native>.
 181
 182 =head1 AUTHORS
 183
 184 Yuval Kogman
 185
 186 Shawn M Moore
 187
 188 Jesse Luehrs
 189
 190 =head1 COPYRIGHT AND LICENSE
 191
 192 Copyright 2007-2009 by Infinity Interactive, Inc.
 193
 194 L<http://www.iinteractive.com>
 195
 196 This library is free software; you can redistribute it and/or modify
 197 it under the same terms as Perl itself.
 198
 199 =cut