t/044-attribute-metaclass.t

   1 #!/usr/bin/env perl
   2 use strict;
   3 use warnings;
   4 use Test::More tests => 7;
   5 use lib 't/lib';
   6
   7 do {
   8     # copied from  MouseX::AttributeHelpers;
   9     package MouseX::AttributeHelpers::Trait::Base;
  10     use Mouse::Role;
  11     use Mouse::Util::TypeConstraints;
  12
  13     requires 'helper_type';
  14
  15     # this is the method map you define ...
  16     has 'provides' => (
  17         is      => 'ro',
  18         isa     => 'HashRef',
  19         default => sub {{}}
  20     );
  21
  22     has 'curries' => (
  23         is      => 'ro',
  24         isa     => 'HashRef',
  25         default => sub {{}}
  26     );
  27
  28     # these next two are the possible methods
  29     # you can use in the 'provides' map.
  30
  31     # provide a Class or Role which we can
  32     # collect the method providers from
  33
  34     # requires_attr 'method_provider'
  35
  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' => (
  40         is      => 'ro',
  41         isa     => 'HashRef',
  42         lazy    => 1,
  43         default => sub {
  44             my $self = shift;
  45             return +{} unless $self->has_method_provider;
  46             # or grab them from the role/class
  47             my $method_provider = $self->method_provider->meta;
  48             return +{
  49                 map {
  50                     $_ => $method_provider->get_method($_)
  51                 }
  52                 grep { $_ ne 'meta' } $method_provider->get_method_list
  53             };
  54         },
  55     );
  56
  57     # extend the parents stuff to make sure
  58     # certain bits are now required ...
  59     #has 'default'         => (required => 1);
  60     has 'type_constraint' => (required => 1);
  61
  62     ## Methods called prior to instantiation
  63
  64     sub process_options_for_provides {
  65         my ($self, $options) = @_;
  66
  67         if (my $type = $self->helper_type) {
  68             (exists $options->{isa})
  69                 || confess "You must define a type with the $type metaclass";
  70
  71             my $isa = $options->{isa};
  72
  73             unless (blessed($isa) && $isa->isa('Mouse::Meta::TypeConstraint')) {
  74                 $isa = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($isa);
  75             }
  76
  77             #($isa->is_a_type_of($type))
  78             #    || confess "The type constraint for a $type ($options->{isa}) must be a subtype of $type";
  79         }
  80     }
  81
  82     before '_process_options' => sub {
  83         my ($self, $name, $options) = @_;
  84         $self->process_options_for_provides($options, $name);
  85     };
  86
  87     ## methods called after instantiation
  88
  89     sub check_provides_values {
  90         my $self = shift;
  91
  92         my $method_constructors = $self->method_constructors;
  93
  94         foreach my $key (keys %{$self->provides}) {
  95             (exists $method_constructors->{$key})
  96                 || confess "$key is an unsupported method type";
  97         }
  98
  99         foreach my $key (keys %{$self->curries}) {
 100             (exists $method_constructors->{$key})
 101                 || confess "$key is an unsupported method type";
 102         }
 103     }
 104
 105     sub _curry {
 106         my $self = shift;
 107         my $code = shift;
 108
 109         my @args = @_;
 110         return sub {
 111             my $self = shift;
 112             $code->($self, @args, @_)
 113         };
 114     }
 115
 116     sub _curry_sub {
 117         my $self = shift;
 118         my $body = shift;
 119         my $code = shift;
 120
 121         return sub {
 122             my $self = shift;
 123             $code->($self, $body, @_)
 124         };
 125     }
 126
 127     after 'install_accessors' => sub {
 128         my $attr  = shift;
 129         my $class = $attr->associated_class;
 130
 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;
 136
 137
 138         # before we install them, lets
 139         # make sure they are valid
 140         $attr->check_provides_values;
 141
 142         my $method_constructors = $attr->method_constructors;
 143
 144         my $class_name = $class->name;
 145
 146         while (my ($constructor, $constructed) = each %{$attr->curries}) {
 147             my $method_code;
 148             while (my ($curried_name, $curried_arg) = each(%$constructed)) {
 149                 if ($class->has_method($curried_name)) {
 150                     confess
 151                         "The method ($curried_name) already ".
 152                         "exists in class (" . $class->name . ")";
 153                 }
 154                 my $body = $method_constructors->{$constructor}->(
 155                            $attr,
 156                            $attr_reader,
 157                            $attr_writer,
 158                 );
 159
 160                 if (ref $curried_arg eq 'ARRAY') {
 161                     $method_code = $attr->_curry($body, @$curried_arg);
 162                 }
 163                 elsif (ref $curried_arg eq 'CODE') {
 164                     $method_code = $attr->_curry_sub($body, $curried_arg);
 165                 }
 166                 else {
 167                     confess "curries parameter must be ref type ARRAY or CODE";
 168                 }
 169
 170                 my $method = MouseX::AttributeHelpers::Meta::Method::Curried->wrap(
 171                     $method_code,
 172                     package_name => $class_name,
 173                     name => $curried_name,
 174                 );
 175
 176                 $attr->associate_method($method);
 177                 $class->add_method($curried_name => $method);
 178             }
 179         }
 180
 181         foreach my $key (keys %{$attr->provides}) {
 182
 183             my $method_name = $attr->provides->{$key};
 184
 185             if ($class->has_method($method_name)) {
 186                 confess "The method ($method_name) already exists in class (" . $class->name . ")";
 187             }
 188
 189             my $method = $method_constructors->{$key}->(
 190                 $attr,
 191                 $attr_reader,
 192                 $attr_writer,
 193             );
 194
 195             $class->add_method($method_name => $method);
 196         }
 197     };
 198
 199     package MouseX::AttributeHelpers::Trait::Number;
 200     use Mouse::Role;
 201
 202     with 'MouseX::AttributeHelpers::Trait::Base';
 203
 204     sub helper_type { 'Num' }
 205
 206     has 'method_constructors' => (
 207         is      => 'ro',
 208         isa     => 'HashRef',
 209         lazy    => 1,
 210         default => sub {
 211             return +{
 212                 set => sub {
 213                     my ($attr, $reader, $writer) = @_;
 214                     return sub { $_[0]->$writer($_[1]) };
 215                 },
 216                 get => sub {
 217                     my ($attr, $reader, $writer) = @_;
 218                     return sub { $_[0]->$reader() };
 219                 },
 220                 add => sub {
 221                     my ($attr, $reader, $writer) = @_;
 222                     return sub { $_[0]->$writer($_[0]->$reader() + $_[1]) };
 223                 },
 224                 sub => sub {
 225                     my ($attr, $reader, $writer) = @_;
 226                     return sub { $_[0]->$writer($_[0]->$reader() - $_[1]) };
 227                 },
 228                 mul => sub {
 229                     my ($attr, $reader, $writer) = @_;
 230                     return sub { $_[0]->$writer($_[0]->$reader() * $_[1]) };
 231                 },
 232                 div => sub {
 233                     my ($attr, $reader, $writer) = @_;
 234                     return sub { $_[0]->$writer($_[0]->$reader() / $_[1]) };
 235                 },
 236                 mod => sub {
 237                     my ($attr, $reader, $writer) = @_;
 238                     return sub { $_[0]->$writer($_[0]->$reader() % $_[1]) };
 239                 },
 240                 abs => sub {
 241                     my ($attr, $reader, $writer) = @_;
 242                     return sub { $_[0]->$writer(abs($_[0]->$reader()) ) };
 243                 },
 244             }
 245         }
 246     );
 247
 248     package MouseX::AttributeHelpers::Number;
 249     use Mouse;
 250
 251     extends 'Mouse::Meta::Attribute';
 252     with 'MouseX::AttributeHelpers::Trait::Number';
 253
 254     no Mouse;
 255
 256     # register an alias for 'metaclass'
 257     package Mouse::Meta::Attribute::Custom::MyNumber;
 258     sub register_implementation { 'MouseX::AttributeHelpers::Number' }
 259
 260     # register an alias for 'traits'
 261     package Mouse::Meta::Attribute::Custom::Trait::MyNumber;
 262     sub register_implementation { 'MouseX::AttributeHelpers::Trait::Number' }
 263
 264     package MyClass;
 265     use Mouse;
 266
 267     has 'i' => (
 268         metaclass => 'MyNumber',
 269         is => 'rw',
 270         isa => 'Int',
 271         provides => {
 272             'add' => 'i_add',
 273         },
 274     );
 275
 276     package MyClassWithTraits;
 277     use Mouse;
 278
 279     has 'ii' => (
 280         isa => 'Num',
 281         provides => {
 282             sub => 'ii_minus',
 283             abs => 'ii_abs',
 284             get => 'get_ii',
 285             set => 'set_ii',
 286        },
 287
 288        traits => [qw(MyNumber)],
 289     );
 290 };
 291
 292 can_ok 'MyClass', 'i_add';
 293 my $k = MyClass->new(i=>3);
 294 $k->i_add(4);
 295 is $k->i, 7;
 296
 297 can_ok 'MyClassWithTraits', qw(ii_minus ii_abs);
 298
 299 $k = MyClassWithTraits->new(ii => 10);
 300 $k->ii_minus(100);
 301 is $k->get_ii, -90;
 302 is $k->ii_abs,  90;
 303
 304 $k->set_ii(10);
 305 is $k->get_ii, 10;
 306 is $k->ii_abs, 10;
 307