From: gfx Date: Fri, 25 Sep 2009 11:10:07 +0000 (+0900) Subject: Fix various tests for new Mouse X-Git-Tag: 0.35~12 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=a09601ab6f3b4b6efb78d3f24a050fec92dcf02f Fix various tests for new Mouse --- diff --git a/Makefile.PL b/Makefile.PL index 86154c9..c26b751 100755 --- a/Makefile.PL +++ b/Makefile.PL @@ -49,13 +49,12 @@ sub create_moose_compatibility_test { # some test does not pass... currently skip it. my %SKIP_TEST = ( '016-trigger.t' => "trigger's argument is incompatble :(", - '029-new.t' => 'Class->new(undef) incompatible', '010-isa-or.t' => 'Mouse has a [BUG]', - '044-attribute-metaclass.t' => 'Moose::Meta::Attribute does not have a "create"', - '047-attribute-metaclass-role.t' => 'Moose::Meta::Attribute does not have a "create"', + '600-tiny-tiny.t' => "Moose doesn't support ::Tiny", '601-tiny-mouse.t' => "Moose doesn't support ::Tiny", '602-mouse-tiny.t' => "Moose doesn't support ::Tiny", + '031_roles_applied_in_create.t' => 't/lib/* classes are not Moose classes/roles', ); @@ -69,6 +68,7 @@ sub create_moose_compatibility_test { return if /failing/; # skip tests in failing/ directories which are Moose specific return if /100_with_moose/; # tests with Moose + return if /deprecated/; my $basename = File::Basename::basename($_); return if $basename =~ /^\./; diff --git a/t/029-new.t b/t/029-new.t index fe660a1..b8a615b 100644 --- a/t/029-new.t +++ b/t/029-new.t @@ -37,9 +37,9 @@ throws_ok { Class->meta->make_immutable; throws_ok { - Class->new('non-hashref scalar'); + Class->new([]); } qr/Single parameters to new\(\) must be a HASH ref/; throws_ok { - Class->new(undef); + Class->new(Class->new); } qr/Single parameters to new\(\) must be a HASH ref/; 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; + diff --git a/t/047-attribute-metaclass-role.t b/t/047-attribute-metaclass-role.t index a4b1945..d621d48 100644 --- a/t/047-attribute-metaclass-role.t +++ b/t/047-attribute-metaclass-role.t @@ -5,15 +5,18 @@ use Test::More tests => 7; use lib 't/lib'; do { - local $SIG{__WARN__} = sub{ $_[0] =~ /deprecated/ or warn @_ }; - package MouseX::AttributeHelpers::Number; use Mouse; extends 'Mouse::Meta::Attribute'; - sub create { - my ($self, @args) = @_; - my $attr = $self->SUPER::create(@args); + has provides => ( + is => 'rw', + isa => 'HashRef', + ); + + after 'install_accessors' => sub{ + my ($attr) = @_; + my %provides = %{$attr->{provides}}; my $method_constructors = { add => sub { @@ -31,8 +34,8 @@ do { return $attr; }; - package # hide me from search.cpan.org - Mouse::Meta::Attribute::Custom::Number; + package + Mouse::Meta::Attribute::Custom::MyNumber; sub register_implementation { 'MouseX::AttributeHelpers::Number' } 1; @@ -41,7 +44,7 @@ do { use Mouse::Role; has 'i' => ( - metaclass => 'Number', + metaclass => 'MyNumber', is => 'rw', isa => 'Int', provides => { @@ -54,7 +57,7 @@ do { use Mouse::Role; has 'j' => ( - metaclass => 'Number', + metaclass => 'MyNumber', is => 'rw', isa => 'Int', provides => { diff --git a/t/800_shikabased/010-isa-or.t b/t/800_shikabased/010-isa-or.t index ef86743..b912815 100644 --- a/t/800_shikabased/010-isa-or.t +++ b/t/800_shikabased/010-isa-or.t @@ -7,14 +7,17 @@ use Test::More tests => 18; use Mouse; use Mouse::Util::TypeConstraints; type Baz => where { defined($_) && $_ eq 'Baz' }; + coerce Baz => from 'ArrayRef', via { 'Baz' }; + has 'bar' => ( is => 'rw', isa => 'Str | Baz | Undef', coerce => 1 ); } eval { Foo->new( bar => +{} ); }; -like($@, qr/^Attribute \(bar\) does not pass the type constraint because: Validation failed for 'Str\|Baz\|Undef' failed with value HASH\(\w+\)/, 'type constraint and coercion failed'); +like($@, qr/^Attribute \(bar\) does not pass the type constraint because: Validation failed for 'Str\|Baz\|Undef' failed with value HASH\(\w+\)/, 'type constraint and coercion failed') + or diag "\$@='$@'"; eval { isa_ok(Foo->new( bar => undef ), 'Foo'); @@ -69,7 +72,7 @@ is $foo->foo, 'Name', 'foo is Name'; { package KLASS; - sub new { bless {}, shift }; + use Mouse; } { package Funk; diff --git a/t/990_deprecated/044-attribute-metaclass.t b/t/990_deprecated/044-attribute-metaclass.t new file mode 100644 index 0000000..bb10b1e --- /dev/null +++ b/t/990_deprecated/044-attribute-metaclass.t @@ -0,0 +1,57 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 2; +use lib 't/lib'; + +do { + local $SIG{__WARN__} = sub{ $_[0] =~ /deprecated/ or warn @_ }; + + package MouseX::AttributeHelpers::Number; + use Mouse; + extends 'Mouse::Meta::Attribute'; + + 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]) + }; + }, + }; + while (my ($name, $aliased) = each %provides) { + $attr->associated_class->add_method( + $aliased => $method_constructors->{$name}->($attr, $attr->name) + ); + } + return $attr; + }; + + package # hide me from search.cpan.org + Mouse::Meta::Attribute::Custom::Number; + sub register_implementation { 'MouseX::AttributeHelpers::Number' } + + 1; + + package Klass; + use Mouse; + + has 'i' => ( + metaclass => 'Number', + is => 'rw', + isa => 'Int', + provides => { + 'add' => 'add_number' + }, + ); +}; + +can_ok 'Klass', 'add_number'; +my $k = Klass->new(i=>3); +$k->add_number(4); +is $k->i, 7; + diff --git a/t/990_deprecated/047-attribute-metaclass-role.t b/t/990_deprecated/047-attribute-metaclass-role.t new file mode 100644 index 0000000..a4b1945 --- /dev/null +++ b/t/990_deprecated/047-attribute-metaclass-role.t @@ -0,0 +1,95 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 7; +use lib 't/lib'; + +do { + local $SIG{__WARN__} = sub{ $_[0] =~ /deprecated/ or warn @_ }; + + package MouseX::AttributeHelpers::Number; + use Mouse; + extends 'Mouse::Meta::Attribute'; + + 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]) + }; + }, + }; + while (my ($name, $aliased) = each %provides) { + $attr->associated_class->add_method( + $aliased => $method_constructors->{$name}->($attr, $attr->name) + ); + } + return $attr; + }; + + package # hide me from search.cpan.org + Mouse::Meta::Attribute::Custom::Number; + sub register_implementation { 'MouseX::AttributeHelpers::Number' } + + 1; + + package Foo; + use Mouse::Role; + + has 'i' => ( + metaclass => 'Number', + is => 'rw', + isa => 'Int', + provides => { + 'add' => 'add_number' + }, + ); + sub f_m {} + + package Bar; + use Mouse::Role; + + has 'j' => ( + metaclass => 'Number', + is => 'rw', + isa => 'Int', + provides => { + 'add' => 'add_number_j' + }, + ); + sub b_m {} + + package Klass1; + use Mouse; + with 'Foo'; + + package Klass2; + use Mouse; + with 'Foo', 'Bar'; + +}; + +{ + # normal + can_ok 'Klass1', 'add_number'; + my $k = Klass1->new(i=>3); + $k->add_number(4); + is $k->i, 7; +} + +{ + # combine + can_ok 'Klass2', 'f_m'; + can_ok 'Klass2', 'b_m'; + can_ok 'Klass2', 'add_number'; + can_ok 'Klass2', 'add_number_j'; + my $k = Klass2->new(i=>3); + $k->add_number(4); + is $k->i, 7; +} + +