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