4 use Test::More tests => 7;
8 # copied from MooseX::AttributeHelpers;
9 package MouseX::AttributeHelpers::Trait::Base;
11 use Mouse::Util::TypeConstraints;
13 requires 'helper_type';
15 # this is the method map you define ...
28 # these next two are the possible methods
29 # you can use in the 'provides' map.
31 # provide a Class or Role which we can
32 # collect the method providers from
34 # requires_attr 'method_provider'
36 # or you can provide a HASH ref of anon subs
37 # yourself. This will also collect and store
38 # the methods from a method_provider as well
39 has 'method_constructors' => (
45 return +{} unless $self->has_method_provider;
46 # or grab them from the role/class
47 my $method_provider = $self->method_provider->meta;
50 $_ => $method_provider->get_method($_)
52 grep { $_ ne 'meta' } $method_provider->get_method_list
57 # extend the parents stuff to make sure
58 # certain bits are now required ...
59 #has 'default' => (required => 1);
60 has 'type_constraint' => (is => 'rw', required => 1);
62 ## Methods called prior to instantiation
64 sub process_options_for_provides {
65 my ($self, $options) = @_;
67 if (my $type = $self->helper_type) {
68 (exists $options->{isa})
69 || confess "You must define a type with the $type metaclass";
71 my $isa = $options->{isa};
73 unless (blessed($isa) && $isa->isa('Mouse::Meta::TypeConstraint')) {
74 $isa = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($isa);
77 #($isa->is_a_type_of($type))
78 # || confess "The type constraint for a $type ($options->{isa}) must be a subtype of $type";
82 before '_process_options' => sub {
83 my ($self, $name, $options) = @_;
84 $self->process_options_for_provides($options, $name);
87 ## methods called after instantiation
89 sub check_provides_values {
92 my $method_constructors = $self->method_constructors;
94 foreach my $key (keys %{$self->provides}) {
95 (exists $method_constructors->{$key})
96 || confess "$key is an unsupported method type";
99 foreach my $key (keys %{$self->curries}) {
100 (exists $method_constructors->{$key})
101 || confess "$key is an unsupported method type";
112 $code->($self, @args, @_)
123 $code->($self, $body, @_)
127 after 'install_accessors' => sub {
129 my $class = $attr->associated_class;
131 # grab the reader and writer methods
132 # as well, this will be useful for
133 # our method provider constructors
134 my $attr_reader = $attr->get_read_method_ref;
135 my $attr_writer = $attr->get_write_method_ref;
138 # before we install them, lets
139 # make sure they are valid
140 $attr->check_provides_values;
142 my $method_constructors = $attr->method_constructors;
144 my $class_name = $class->name;
146 while (my ($constructor, $constructed) = each %{$attr->curries}) {
148 while (my ($curried_name, $curried_arg) = each(%$constructed)) {
149 if ($class->has_method($curried_name)) {
151 "The method ($curried_name) already ".
152 "exists in class (" . $class->name . ")";
154 my $body = $method_constructors->{$constructor}->(
160 if (ref $curried_arg eq 'ARRAY') {
161 $method_code = $attr->_curry($body, @$curried_arg);
163 elsif (ref $curried_arg eq 'CODE') {
164 $method_code = $attr->_curry_sub($body, $curried_arg);
167 confess "curries parameter must be ref type ARRAY or CODE";
170 my $method = MouseX::AttributeHelpers::Meta::Method::Curried->wrap(
172 package_name => $class_name,
173 name => $curried_name,
176 $attr->associate_method($method);
177 $class->add_method($curried_name => $method);
181 foreach my $key (keys %{$attr->provides}) {
183 my $method_name = $attr->provides->{$key};
185 if ($class->has_method($method_name)) {
186 confess "The method ($method_name) already exists in class (" . $class->name . ")";
189 my $method = $method_constructors->{$key}->(
195 $class->add_method($method_name => $method);
199 package MouseX::AttributeHelpers::Trait::Number;
202 with 'MouseX::AttributeHelpers::Trait::Base';
204 sub helper_type { 'Num' }
206 has 'method_constructors' => (
213 my ( $attr, $reader, $writer ) = @_;
214 return sub { $writer->( $_[0], $_[1] ) };
217 my ( $attr, $reader, $writer ) = @_;
218 return sub { $reader->( $_[0] ) };
221 my ( $attr, $reader, $writer ) = @_;
222 return sub { $writer->( $_[0], $reader->( $_[0] ) + $_[1] ) };
225 my ( $attr, $reader, $writer ) = @_;
226 return sub { $writer->( $_[0], $reader->( $_[0] ) - $_[1] ) };
229 my ( $attr, $reader, $writer ) = @_;
230 return sub { $writer->( $_[0], $reader->( $_[0] ) * $_[1] ) };
233 my ( $attr, $reader, $writer ) = @_;
234 return sub { $writer->( $_[0], $reader->( $_[0] ) / $_[1] ) };
237 my ( $attr, $reader, $writer ) = @_;
238 return sub { $writer->( $_[0], $reader->( $_[0] ) % $_[1] ) };
241 my ( $attr, $reader, $writer ) = @_;
242 return sub { $writer->( $_[0], abs( $reader->( $_[0] ) ) ) };
249 package MouseX::AttributeHelpers::Number;
252 extends 'Mouse::Meta::Attribute';
253 with 'MouseX::AttributeHelpers::Trait::Number';
257 # register an alias for 'metaclass'
258 package Mouse::Meta::Attribute::Custom::MyNumber;
259 sub register_implementation { 'MouseX::AttributeHelpers::Number' }
261 # register an alias for 'traits'
262 package Mouse::Meta::Attribute::Custom::Trait::MyNumber;
263 sub register_implementation { 'MouseX::AttributeHelpers::Trait::Number' }
269 metaclass => 'MyNumber',
277 package MyClassWithTraits;
282 predicate => 'has_ii',
291 traits => [qw(MyNumber)],
295 can_ok 'MyClass', 'i_add';
296 my $k = MyClass->new(i=>3);
300 can_ok 'MyClassWithTraits', qw(ii_minus ii_abs);
302 $k = MyClassWithTraits->new(ii => 10);