t/001_mouse/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  MooseX::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' => (is => 'rw', 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' => (\r
 207         is      => 'ro',\r
 208         isa     => 'HashRef',\r
 209         lazy    => 1,\r
 210         default => sub {\r
 211             return +{\r
 212                 set => sub {\r
 213                     my ( $attr, $reader, $writer ) = @_;\r
 214                     return sub { $writer->( $_[0], $_[1] ) };\r
 215                 },
 216                 get => sub {\r
 217                     my ( $attr, $reader, $writer ) = @_;\r
 218                     return sub { $reader->( $_[0] ) };\r
 219                 },
 220                 add => sub {\r
 221                     my ( $attr, $reader, $writer ) = @_;\r
 222                     return sub { $writer->( $_[0], $reader->( $_[0] ) + $_[1] ) };\r
 223                 },\r
 224                 sub => sub {\r
 225                     my ( $attr, $reader, $writer ) = @_;\r
 226                     return sub { $writer->( $_[0], $reader->( $_[0] ) - $_[1] ) };\r
 227                 },\r
 228                 mul => sub {\r
 229                     my ( $attr, $reader, $writer ) = @_;\r
 230                     return sub { $writer->( $_[0], $reader->( $_[0] ) * $_[1] ) };\r
 231                 },\r
 232                 div => sub {\r
 233                     my ( $attr, $reader, $writer ) = @_;\r
 234                     return sub { $writer->( $_[0], $reader->( $_[0] ) / $_[1] ) };\r
 235                 },\r
 236                 mod => sub {\r
 237                     my ( $attr, $reader, $writer ) = @_;\r
 238                     return sub { $writer->( $_[0], $reader->( $_[0] ) % $_[1] ) };\r
 239                 },\r
 240                 abs => sub {\r
 241                     my ( $attr, $reader, $writer ) = @_;\r
 242                     return sub { $writer->( $_[0], abs( $reader->( $_[0] ) ) ) };\r
 243                 },\r
 244             };\r
 245         }\r
 246     );\r
 247 \r
 248
 249     package MouseX::AttributeHelpers::Number;
 250     use Mouse;
 251
 252     extends 'Mouse::Meta::Attribute';
 253     with 'MouseX::AttributeHelpers::Trait::Number';
 254
 255     no Mouse;
 256
 257     # register an alias for 'metaclass'
 258     package Mouse::Meta::Attribute::Custom::MyNumber;
 259     sub register_implementation { 'MouseX::AttributeHelpers::Number' }
 260
 261     # register an alias for 'traits'
 262     package Mouse::Meta::Attribute::Custom::Trait::MyNumber;
 263     sub register_implementation { 'MouseX::AttributeHelpers::Trait::Number' }
 264
 265     package MyClass;
 266     use Mouse;
 267
 268     has 'i' => (
 269         metaclass => 'MyNumber',
 270         is => 'rw',
 271         isa => 'Int',
 272         provides => {
 273             'add' => 'i_add',
 274         },
 275     );
 276
 277     package MyClassWithTraits;
 278     use Mouse;
 279
 280     has 'ii' => (
 281         isa => 'Num',
 282         predicate => 'has_ii',
 283
 284         provides => {
 285             sub => 'ii_minus',
 286             abs => 'ii_abs',
 287             get => 'get_ii',
 288             set => 'set_ii',
 289        },
 290
 291        traits => [qw(MyNumber)],
 292     );
 293 };
 294
 295 can_ok 'MyClass', 'i_add';
 296 my $k = MyClass->new(i=>3);
 297 $k->i_add(4);
 298 is $k->i, 7;
 299
 300 can_ok 'MyClassWithTraits', qw(ii_minus ii_abs);
 301
 302 $k = MyClassWithTraits->new(ii => 10);
 303 $k->ii_minus(100);
 304 is $k->get_ii, -90;
 305 $k->ii_abs;
 306 is $k->get_ii,  90;
 307
 308 $k->set_ii(10);
 309 is $k->get_ii, 10;
 310 $k->ii_abs;
 311 is $k->get_ii, 10;
 312