X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=t%2F044-attribute-metaclass.t;h=71fdd11026c912ffe282548a86c4ecbd242d3884;hp=bb10b1edd8f251cfa9f22567bbea1cb32508beb9;hb=a09601ab6f3b4b6efb78d3f24a050fec92dcf02f;hpb=bf8e5b90e442d6ec7dbb837a051f547d685ee2e9 diff --git a/t/044-attribute-metaclass.t b/t/044-attribute-metaclass.t index bb10b1e..71fdd11 100644 --- a/t/044-attribute-metaclass.t +++ b/t/044-attribute-metaclass.t @@ -1,57 +1,298 @@ #!/usr/bin/env perl use strict; use warnings; -use Test::More tests => 2; +use Test::More tests => 5; use lib 't/lib'; do { - local $SIG{__WARN__} = sub{ $_[0] =~ /deprecated/ or warn @_ }; + # copied from MouseX::AttributeHelpers; + package MouseX::AttributeHelpers::Trait::Base; + use Mouse::Role; + use Mouse::Util::TypeConstraints; - package MouseX::AttributeHelpers::Number; - use Mouse; - extends 'Mouse::Meta::Attribute'; + requires 'helper_type'; + + # this is the method map you define ... + has 'provides' => ( + is => 'ro', + isa => 'HashRef', + default => sub {{}} + ); + + has 'curries' => ( + is => 'ro', + isa => 'HashRef', + default => sub {{}} + ); + + # these next two are the possible methods + # you can use in the 'provides' map. + + # provide a Class or Role which we can + # collect the method providers from + + # requires_attr 'method_provider' + + # or you can provide a HASH ref of anon subs + # yourself. This will also collect and store + # the methods from a method_provider as well + has 'method_constructors' => ( + is => 'ro', + isa => 'HashRef', + lazy => 1, + default => sub { + my $self = shift; + return +{} unless $self->has_method_provider; + # or grab them from the role/class + my $method_provider = $self->method_provider->meta; + return +{ + map { + $_ => $method_provider->get_method($_) + } + grep { $_ ne 'meta' } $method_provider->get_method_list + }; + }, + ); + + # extend the parents stuff to make sure + # certain bits are now required ... + #has '+default' => (required => 1); + #has '+type_constraint' => (required => 1); + + ## Methods called prior to instantiation + + sub process_options_for_provides { + my ($self, $options) = @_; + + if (my $type = $self->helper_type) { + (exists $options->{isa}) + || confess "You must define a type with the $type metaclass"; + + my $isa = $options->{isa}; - sub create { - my ($self, @args) = @_; - my $attr = $self->SUPER::create(@args); - my %provides = %{$attr->{provides}}; - my $method_constructors = { - add => sub { - my ($attr, $name) = @_; - return sub { - $_[0]->$name( $_[0]->$name() + $_[1]) - }; - }, + unless (blessed($isa) && $isa->isa('Mouse::Meta::TypeConstraint')) { + $isa = Mouse::Util::TypeConstraints::find_or_create_isa_type_constraint($isa); + } + + #($isa->is_a_type_of($type)) + # || confess "The type constraint for a $type ($options->{isa}) must be a subtype of $type"; + } + } + + before '_process_options' => sub { + my ($self, $name, $options) = @_; + $self->process_options_for_provides($options, $name); + }; + + ## methods called after instantiation + + sub check_provides_values { + my $self = shift; + + my $method_constructors = $self->method_constructors; + + foreach my $key (keys %{$self->provides}) { + (exists $method_constructors->{$key}) + || confess "$key is an unsupported method type"; + } + + foreach my $key (keys %{$self->curries}) { + (exists $method_constructors->{$key}) + || confess "$key is an unsupported method type"; + } + } + + sub _curry { + my $self = shift; + my $code = shift; + + my @args = @_; + return sub { + my $self = shift; + $code->($self, @args, @_) }; - while (my ($name, $aliased) = each %provides) { - $attr->associated_class->add_method( - $aliased => $method_constructors->{$name}->($attr, $attr->name) + } + + sub _curry_sub { + my $self = shift; + my $body = shift; + my $code = shift; + + return sub { + my $self = shift; + $code->($self, $body, @_) + }; + } + + after 'install_accessors' => sub { + my $attr = shift; + my $class = $attr->associated_class; + + # grab the reader and writer methods + # as well, this will be useful for + # our method provider constructors + my $attr_reader = $attr->get_read_method; + my $attr_writer = $attr->get_write_method; + + + # before we install them, lets + # make sure they are valid + $attr->check_provides_values; + + my $method_constructors = $attr->method_constructors; + + my $class_name = $class->name; + + while (my ($constructor, $constructed) = each %{$attr->curries}) { + my $method_code; + while (my ($curried_name, $curried_arg) = each(%$constructed)) { + if ($class->has_method($curried_name)) { + confess + "The method ($curried_name) already ". + "exists in class (" . $class->name . ")"; + } + my $body = $method_constructors->{$constructor}->( + $attr, + $attr_reader, + $attr_writer, + ); + + if (ref $curried_arg eq 'ARRAY') { + $method_code = $attr->_curry($body, @$curried_arg); + } + elsif (ref $curried_arg eq 'CODE') { + $method_code = $attr->_curry_sub($body, $curried_arg); + } + else { + confess "curries parameter must be ref type ARRAY or CODE"; + } + + my $method = MouseX::AttributeHelpers::Meta::Method::Curried->wrap( + $method_code, + package_name => $class_name, + name => $curried_name, + ); + + $attr->associate_method($method); + $class->add_method($curried_name => $method); + } + } + + foreach my $key (keys %{$attr->provides}) { + + my $method_name = $attr->provides->{$key}; + + if ($class->has_method($method_name)) { + confess "The method ($method_name) already exists in class (" . $class->name . ")"; + } + + my $method = $method_constructors->{$key}->( + $attr, + $attr_reader, + $attr_writer, ); + + $class->add_method($method_name => $method); } - return $attr; }; - package # hide me from search.cpan.org - Mouse::Meta::Attribute::Custom::Number; + package MouseX::AttributeHelpers::Trait::Number; + use Mouse::Role; + + with 'MouseX::AttributeHelpers::Trait::Base'; + + sub helper_type { 'Num' } + + has 'method_constructors' => ( + is => 'ro', + isa => 'HashRef', + lazy => 1, + default => sub { + return +{ + set => sub { + my ($attr, $reader, $writer) = @_; + return sub { $_[0]->$writer($_[1]) }; + }, + add => sub { + my ($attr, $reader, $writer) = @_; + return sub { $_[0]->$writer($_[0]->$reader() + $_[1]) }; + }, + sub => sub { + my ($attr, $reader, $writer) = @_; + return sub { $_[0]->$writer($_[0]->$reader() - $_[1]) }; + }, + mul => sub { + my ($attr, $reader, $writer) = @_; + return sub { $_[0]->$writer($_[0]->$reader() * $_[1]) }; + }, + div => sub { + my ($attr, $reader, $writer) = @_; + return sub { $_[0]->$writer($_[0]->$reader() / $_[1]) }; + }, + mod => sub { + my ($attr, $reader, $writer) = @_; + return sub { $_[0]->$writer($_[0]->$reader() % $_[1]) }; + }, + abs => sub { + my ($attr, $reader, $writer) = @_; + return sub { $_[0]->$writer(abs($_[0]->$reader()) ) }; + }, + } + } + ); + + package MouseX::AttributeHelpers::Number; + use Mouse; + + extends 'Mouse::Meta::Attribute'; + with 'MouseX::AttributeHelpers::Trait::Number'; + + no Mouse; + + # register an alias for 'metaclass' + package Mouse::Meta::Attribute::Custom::MyNumber; sub register_implementation { 'MouseX::AttributeHelpers::Number' } - 1; + # register an alias for 'traits' + package Mouse::Meta::Attribute::Custom::Trait::MyNumber; + sub register_implementation { 'MouseX::AttributeHelpers::Trait::Number' } - package Klass; + package MyClass; use Mouse; has 'i' => ( - metaclass => 'Number', + metaclass => 'MyNumber', is => 'rw', isa => 'Int', provides => { - 'add' => 'add_number' + 'add' => 'i_add', }, ); + + package MyClassWithTraits; + use Mouse; + + has 'ii' => ( + is => 'rw', + isa => 'Num', + provides => { + sub => 'ii_minus', + abs => 'ii_abs', + }, + + traits => [qw(MyNumber)], + ); }; -can_ok 'Klass', 'add_number'; -my $k = Klass->new(i=>3); -$k->add_number(4); +can_ok 'MyClass', 'i_add'; +my $k = MyClass->new(i=>3); +$k->i_add(4); is $k->i, 7; +can_ok 'MyClassWithTraits', qw(ii_minus ii_abs); + +$k = MyClassWithTraits->new(ii => 10); +$k->ii_minus(100); +is $k->ii, -90; +is $k->ii_abs, 90; +