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 uniq );
   6 use Moose::Util::TypeConstraints;
   7 use Moose::Deprecated;
   8
   9 our $AUTHORITY = 'cpan:STEVAN';
  10
  11 requires '_helper_type';
  12
  13 has _used_default_is => (
  14     is      => 'rw',
  15     isa     => 'Bool',
  16     default => 0,
  17 );
  18
  19 before '_process_options' => sub {
  20     my ( $self, $name, $options ) = @_;
  21
  22     $self->_check_helper_type( $options, $name );
  23
  24     if ( !( any { exists $options->{$_} } qw( is reader writer accessor ) )
  25         && $self->can('_default_is') ) {
  26
  27         $options->{is} = $self->_default_is;
  28
  29         $options->{_used_default_is} = 1;
  30     }
  31
  32     if (
  33         !(
  34             $options->{required}
  35             || any { exists $options->{$_} } qw( default builder lazy_build )
  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                 . ' You can avoid this warning by supplying a default, builder, or making the attribute required'
  47         );
  48     }
  49 };
  50
  51 after 'install_accessors' => sub {
  52     my $self = shift;
  53
  54     return unless $self->_used_default_is;
  55
  56     my @methods
  57         = $self->_default_is eq 'rw'
  58         ? qw( reader writer accessor )
  59         : 'reader';
  60
  61     my $name = $self->name;
  62     my $class = $self->associated_class->name;
  63
  64     for my $meth ( uniq grep {defined} map { $self->$_ } @methods ) {
  65
  66         my $message
  67             = "The $meth method in the $class class was automatically created"
  68             . " by the native delegation trait for the $name attribute."
  69             . q{ This "default is" feature is deprecated.}
  70             . q{ Explicitly set "is" or define accessor names to avoid this};
  71
  72         $self->associated_class->add_before_method_modifier(
  73             $meth => sub {
  74                 Moose::Deprecated::deprecated(
  75                     feature => 'default is for Native Trait',
  76                     message =>$message,
  77                 );
  78             }
  79         );
  80     }
  81     };
  82
  83 sub _check_helper_type {
  84     my ( $self, $options, $name ) = @_;
  85
  86     my $type = $self->_helper_type;
  87
  88     $options->{isa} = $type
  89         unless exists $options->{isa};
  90
  91     my $isa = Moose::Util::TypeConstraints::find_or_create_type_constraint(
  92         $options->{isa} );
  93
  94     ( $isa->is_a_type_of($type) )
  95         || confess
  96         "The type constraint for $name must be a subtype of $type but it's a $isa";
  97 }
  98
  99 before 'install_accessors' => sub { (shift)->_check_handles_values };
 100
 101 sub _check_handles_values {
 102     my $self = shift;
 103
 104     my %handles = $self->_canonicalize_handles;
 105
 106     for my $original_method ( values %handles ) {
 107         my $name = $original_method->[0];
 108
 109         my $accessor_class = $self->_native_accessor_class_for($name);
 110
 111         ( $accessor_class && $accessor_class->can('new') )
 112             || confess
 113             "$name is an unsupported method type - $accessor_class";
 114     }
 115 }
 116
 117 around '_canonicalize_handles' => sub {
 118     shift;
 119     my $self    = shift;
 120     my $handles = $self->handles;
 121
 122     return unless $handles;
 123
 124     unless ( 'HASH' eq ref $handles ) {
 125         $self->throw_error(
 126             "The 'handles' option must be a HASH reference, not $handles");
 127     }
 128
 129     return map {
 130         my $to = $handles->{$_};
 131         $to = [$to] unless ref $to;
 132         $_ => $to
 133     } keys %$handles;
 134 };
 135
 136 around '_make_delegation_method' => sub {
 137     my $next = shift;
 138     my ( $self, $handle_name, $method_to_call ) = @_;
 139
 140     my ( $name, @curried_args ) = @$method_to_call;
 141
 142     my $accessor_class = $self->_native_accessor_class_for($name);
 143
 144     die "Cannot find an accessor class for $name"
 145         unless $accessor_class && $accessor_class->can('new');
 146
 147     return $accessor_class->new(
 148         name               => $handle_name,
 149         package_name       => $self->associated_class->name,
 150         delegate_to_method => $name,
 151         attribute          => $self,
 152         is_inline          => 1,
 153         curried_arguments  => \@curried_args,
 154         root_types         => [ $self->_root_types ],
 155     );
 156 };
 157
 158 sub _root_types {
 159     return $_[0]->_helper_type;
 160 }
 161
 162 sub _native_accessor_class_for {
 163     my ( $self, $suffix ) = @_;
 164
 165     my $role
 166         = 'Moose::Meta::Method::Accessor::Native::'
 167         . $self->_native_type . '::'
 168         . $suffix;
 169
 170     Class::MOP::load_class($role);
 171     return Moose::Meta::Class->create_anon_class(
 172         superclasses =>
 173             [ $self->accessor_metaclass, $self->delegation_metaclass ],
 174         roles => [$role],
 175         cache => 1,
 176     )->name;
 177 }
 178
 179 sub _build_native_type {
 180     my $self = shift;
 181
 182     for my $role_name ( map { $_->name } $self->meta->calculate_all_roles ) {
 183         return $1 if $role_name =~ /::Native::Trait::(\w+)$/;
 184     }
 185
 186     die "Cannot calculate native type for " . ref $self;
 187 }
 188
 189 has '_native_type' => (
 190     is      => 'ro',
 191     isa     => 'Str',
 192     lazy    => 1,
 193     builder => '_build_native_type',
 194 );
 195
 196 no Moose::Role;
 197 no Moose::Util::TypeConstraints;
 198
 199 1;
 200
 201 # ABSTRACT: Shared role for native delegation traits
 202
 203 __END__
 204
 205 =head1 BUGS
 206
 207 See L<Moose/BUGS> for details on reporting bugs.
 208
 209 =head1 SEE ALSO
 210
 211 Documentation for Moose native traits can be found in
 212 L<Moose::Meta::Attribute::Native>.
 213
 214 =cut