From: gfx Date: Tue, 22 Sep 2009 07:40:47 +0000 (+0900) Subject: Add various things X-Git-Tag: 0.32~7 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7a50b45027c9f7baad76cfce7f78c822bd38f0a7;p=gitmo%2FMouse.git Add various things --- diff --git a/Changes b/Changes index 52cb806..cf609ef 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,8 @@ Revision history for Mouse +0.32 + + 0.31 Tue Sep 22 11:08:12 2009 * Add find_meta() and does_role() to Mouse::Util (gfx) diff --git a/lib/Mouse.pm b/lib/Mouse.pm index 1c76f7c..6948ce5 100644 --- a/lib/Mouse.pm +++ b/lib/Mouse.pm @@ -15,6 +15,7 @@ use Mouse::Util qw(load_class is_class_loaded); use Mouse::Meta::Attribute; use Mouse::Meta::Module; use Mouse::Meta::Class; +use Mouse::Meta::Role; use Mouse::Object; use Mouse::Util::TypeConstraints; diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm index 2689f85..7084439 100644 --- a/lib/Mouse/Meta/Class.pm +++ b/lib/Mouse/Meta/Class.pm @@ -23,7 +23,19 @@ sub _new { \@{ $args{package} . '::ISA' }; }; - bless \%args, $class; + #return Mouse::Meta::Class->initialize($class)->new_object(%args) + # if $class ne __PACKAGE__; + + return bless \%args, $class; +} + +sub create_anon_class{ + my $self = shift; + return $self->create(undef, @_); +} + +sub is_anon_class{ + return exists $_[0]->{anon_serial_id}; } sub roles { $_[0]->{roles} } @@ -53,11 +65,12 @@ sub add_attribute { if (@_ == 1 && blessed($_[0])) { my $attr = shift @_; $self->{'attributes'}{$attr->name} = $attr; - } else { + } + else { my $names = shift @_; $names = [$names] if !ref($names); my $metaclass = 'Mouse::Meta::Attribute'; - my %options = @_; + my %options = (@_ == 1 ? %{$_[0]} : @_); if ( my $metaclass_name = delete $options{metaclass} ) { my $new_class = Mouse::Util::resolve_metaclass_alias( @@ -71,10 +84,10 @@ sub add_attribute { for my $name (@$names) { if ($name =~ s/^\+//) { - $metaclass->clone_parent($self, $name, @_); + $metaclass->clone_parent($self, $name, %options); } else { - $metaclass->create($self, $name, @_); + $metaclass->create($self, $name, %options); } } } @@ -102,7 +115,7 @@ sub linearized_isa { @{ get_linear_isa($_[0]->name) } } sub new_object { my $self = shift; - my $args = (@_ == 1) ? $_[0] : { @_ }; + my %args = (@_ == 1 ? %{$_[0]} : @_); my $instance = bless {}, $self->name; @@ -110,18 +123,18 @@ sub new_object { my $from = $attribute->init_arg; my $key = $attribute->name; - if (defined($from) && exists($args->{$from})) { - $args->{$from} = $attribute->coerce_constraint($args->{$from}) + if (defined($from) && exists($args{$from})) { + $args{$from} = $attribute->coerce_constraint($args{$from}) if $attribute->should_coerce; - $attribute->verify_against_type_constraint($args->{$from}); + $attribute->verify_against_type_constraint($args{$from}); - $instance->{$key} = $args->{$from}; + $instance->{$key} = $args{$from}; weaken($instance->{$key}) if ref($instance->{$key}) && $attribute->is_weak_ref; if ($attribute->has_trigger) { - $attribute->trigger->($instance, $args->{$from}); + $attribute->trigger->($instance, $args{$from}); } } else { @@ -293,133 +306,6 @@ sub does_role { return 0; } -sub create { - my ($class, $package_name, %options) = @_; - - (ref $options{superclasses} eq 'ARRAY') - || $class->throw_error("You must pass an ARRAY ref of superclasses") - if exists $options{superclasses}; - - (ref $options{attributes} eq 'ARRAY') - || $class->throw_error("You must pass an ARRAY ref of attributes") - if exists $options{attributes}; - - (ref $options{methods} eq 'HASH') - || $class->throw_error("You must pass a HASH ref of methods") - if exists $options{methods}; - - (ref $options{roles} eq 'ARRAY') - || $class->throw_error("You must pass an ARRAY ref of roles") - if exists $options{roles}; - - # instantiate a module - { - ( defined $package_name && $package_name ) - || $class->throw_error("You must pass a package name"); - - no strict 'refs'; - ${ $package_name . '::VERSION' } = $options{version} if exists $options{version}; - ${ $package_name . '::AUTHORITY' } = $options{authority} if exists $options{authority}; - } - - my %initialize_options = %options; - delete @initialize_options{qw( - package - superclasses - attributes - methods - roles - version - authority - )}; - my $meta = $class->initialize( $package_name => %initialize_options ); - - # FIXME totally lame - $meta->add_method('meta' => sub { - Mouse::Meta::Class->initialize(ref($_[0]) || $_[0]); - }); - - $meta->superclasses(@{$options{superclasses}}) - if exists $options{superclasses}; - - # NOTE: - # process attributes first, so that they can - # install accessors, but locally defined methods - # can then overwrite them. It is maybe a little odd, but - # I think this should be the order of things. - if (exists $options{attributes}) { - foreach my $attr (@{$options{attributes}}) { - Mouse::Meta::Attribute->create($meta, $attr->{name}, %$attr); - } - } - if (exists $options{methods}) { - foreach my $method_name (keys %{$options{methods}}) { - $meta->add_method($method_name, $options{methods}->{$method_name}); - } - } - if (exists $options{roles}){ - Mouse::Util::apply_all_roles($package_name, @{$options{roles}}); - } - return $meta; -} - -{ - my $ANON_CLASS_SERIAL = 0; - my $ANON_CLASS_PREFIX = 'Mouse::Meta::Class::__ANON__::SERIAL::'; - - my %IMMORTAL_ANON_CLASSES; - sub create_anon_class { - my ( $class, %options ) = @_; - - my $cache = $options{cache}; - my $cache_key; - - if($cache){ # anonymous but not mortal - # something like Super::Class|Super::Class::2=Role|Role::1 - $cache_key = join '=' => ( - join('|', @{$options{superclasses} || []}), - join('|', sort @{$options{roles} || []}), - ); - return $IMMORTAL_ANON_CLASSES{$cache_key} if exists $IMMORTAL_ANON_CLASSES{$cache_key}; - } - my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL; - my $meta = $class->create( $package_name, anon_class_id => $ANON_CLASS_SERIAL, %options ); - - if($cache){ - $IMMORTAL_ANON_CLASSES{$cache_key} = $meta; - } - else{ - Mouse::Meta::Module::weaken_metaclass($package_name); - } - return $meta; - } - - sub is_anon_class{ - return exists $_[0]->{anon_class_id}; - } - - - sub DESTROY{ - my($self) = @_; - - my $serial_id = $self->{anon_class_id}; - - return if !$serial_id; - - my $stash = $self->namespace; - - @{$self->{sperclasses}} = (); - %{$stash} = (); - Mouse::Meta::Module::remove_metaclass_by_name($self->name); - - no strict 'refs'; - delete ${$ANON_CLASS_PREFIX}{ $serial_id . '::' }; - - return; - } - -} - 1; __END__ diff --git a/lib/Mouse/Meta/Module.pm b/lib/Mouse/Meta/Module.pm index 091b8ef..74a8468 100755 --- a/lib/Mouse/Meta/Module.pm +++ b/lib/Mouse/Meta/Module.pm @@ -5,7 +5,6 @@ use warnings; use Mouse::Util qw/get_code_info not_supported load_class/; use Scalar::Util qw/blessed weaken/; - { my %METACLASS_CACHE; @@ -137,6 +136,146 @@ sub get_method_list { return grep { $self->has_method($_) } keys %{ $self->namespace }; } +{ + my $ANON_SERIAL = 0; + my $ANON_PREFIX = 'Mouse::Meta::Module::__ANON__::'; + + my %IMMORTALS; + + sub create { + my ($class, $package_name, %options) = @_; + + $class->throw_error('You must pass a package name') if @_ == 1; + + + if(exists $options{superclasses}){ + if($class->isa('Mouse::Meta::Class')){ + (ref $options{superclasses} eq 'ARRAY') + || $class->throw_error("You must pass an ARRAY ref of superclasses"); + } + else{ # role + delete $options{superclasses}; + } + } + + my $attributes; + if(exists $options{attributes}){ + $attributes = delete $options{attributes}; + (ref $attributes eq 'ARRAY' || ref $attributes eq 'HASH') + || $class->throw_error("You must pass an ARRAY ref of attributes") + } + + (ref $options{methods} eq 'HASH') + || $class->throw_error("You must pass a HASH ref of methods") + if exists $options{methods}; + + (ref $options{roles} eq 'ARRAY') + || $class->throw_error("You must pass an ARRAY ref of roles") + if exists $options{roles}; + + + my @extra_options; + my $mortal; + my $cache_key; + + if(!defined $package_name){ # anonymous + $mortal = !$options{cache}; + + # anonymous but immortal + if(!$mortal){ + # something like Super::Class|Super::Class::2=Role|Role::1 + $cache_key = join '=' => ( + join('|', @{$options{superclasses} || []}), + join('|', sort @{$options{roles} || []}), + ); + return $IMMORTALS{$cache_key} if exists $IMMORTALS{$cache_key}; + } + $package_name = $ANON_PREFIX . ++$ANON_SERIAL; + + push @extra_options, (anon_serial_id => $ANON_SERIAL); + } + + # instantiate a module + { + no strict 'refs'; + ${ $package_name . '::VERSION' } = delete $options{version} if exists $options{version}; + ${ $package_name . '::AUTHORITY' } = delete $options{authority} if exists $options{authority}; + } + + my %initialize_options = %options; + delete @initialize_options{qw( + package + superclasses + attributes + methods + roles + )}; + my $meta = $class->initialize( $package_name, %initialize_options, @extra_options); + + Mouse::Meta::Module::weaken_metaclass($package_name) + if $mortal; + + # FIXME totally lame + $meta->add_method('meta' => sub { + $class->initialize(ref($_[0]) || $_[0]); + }); + + $meta->superclasses(@{$options{superclasses}}) + if exists $options{superclasses}; + + # NOTE: + # process attributes first, so that they can + # install accessors, but locally defined methods + # can then overwrite them. It is maybe a little odd, but + # I think this should be the order of things. + if (defined $attributes) { + if(ref($attributes) eq 'ARRAY'){ + foreach my $attr (@{$attributes}) { + $meta->add_attribute($attr->{name} => $attr); + } + } + else{ + while(my($name, $attr) = each %{$attributes}){ + $meta->add_attribute($name => $attr); + } + } + } + if (exists $options{methods}) { + foreach my $method_name (keys %{$options{methods}}) { + $meta->add_method($method_name, $options{methods}->{$method_name}); + } + } + if (exists $options{roles}){ + Mouse::Util::apply_all_roles($package_name, @{$options{roles}}); + } + + if(!$mortal && exists $meta->{anon_serial_id}){ + $IMMORTALS{$cache_key} = $meta; + } + + return $meta; + } + + sub DESTROY{ + my($self) = @_; + + my $serial_id = $self->{anon_serial_id}; + + return if !$serial_id; + + my $stash = $self->namespace; + + @{$self->{superclasses}} = () if exists $self->{superclasses}; + %{$stash} = (); + Mouse::Meta::Module::remove_metaclass_by_name($self->name); + + no strict 'refs'; + delete ${$ANON_PREFIX}{ $serial_id . '::' }; + + return; + } +} + sub throw_error{ my($class, $message, %args) = @_; diff --git a/lib/Mouse/Meta/Role.pm b/lib/Mouse/Meta/Role.pm index 33b8426..48e1b81 100644 --- a/lib/Mouse/Meta/Role.pm +++ b/lib/Mouse/Meta/Role.pm @@ -9,6 +9,7 @@ sub method_metaclass(){ 'Mouse::Meta::Role::Method' } # required for get_method( sub _new { my $class = shift; + my %args = @_; $args{methods} ||= {}; @@ -16,7 +17,19 @@ sub _new { $args{required_methods} ||= []; $args{roles} ||= []; - bless \%args, $class; +# return Mouse::Meta::Class->initialize($class)->new_object(%args) +# if $class ne __PACKAGE__; + + return bless \%args, $class; +} + +sub create_anon_role{ + my $self = shift; + return $self->create(undef, @_); +} + +sub is_anon_role{ + return exists $_[0]->{anon_serial_id}; } sub get_roles { $_[0]->{roles} } @@ -43,14 +56,50 @@ sub add_attribute { $self->{attributes}->{$name} = (@_ == 1) ? $_[0] : { @_ }; } +sub _canonicalize_apply_args{ + my($self, $applicant, %args) = @_; + + if($applicant->isa('Mouse::Meta::Class')){ + $args{_to} = 'class'; + } + elsif($applicant->isa('Mouse::Meta::Role')){ + $args{_to} = 'role'; + } + else{ + $args{_to} = 'instance'; + + not_supported 'Application::ToInstance'; + } + + if($args{alias} && !exists $args{-alias}){ + $args{-alias} = $args{alias}; + } + if($args{excludes} && !exists $args{-excludes}){ + $args{-excludes} = $args{excludes}; + } + + if(my $excludes = $args{-excludes}){ + $args{-excludes} = {}; # replace with a hash ref + if(ref $excludes){ + %{$args{-excludes}} = (map{ $_ => undef } @{$excludes}); + } + else{ + $args{-excludes}{$excludes} = undef; + } + } + + return \%args; +} + sub _check_required_methods{ my($role, $class, $args, @other_roles) = @_; - if($class->isa('Mouse::Meta::Class')){ + if($args->{_to} eq 'class'){ my $class_name = $class->name; + my $role_name = $role->name; + my @missing; foreach my $method_name(@{$role->{required_methods}}){ - unless($class_name->can($method_name)){ - my $role_name = $role->name; + if(!$class_name->can($method_name)){ my $has_method = 0; foreach my $another_role_spec(@other_roles){ @@ -60,11 +109,24 @@ sub _check_required_methods{ last; } } - - $role->throw_error("'$role_name' requires the method '$method_name' to be implemented by '$class_name'") - unless $has_method; + + push @missing, $method_name if !$has_method; } } + if(@missing){ + $class->throw_error("'$role_name' requires the " + . (@missing == 1 ? 'method' : 'methods') + . " " + . english_list(map{ sprintf q{'%s'}, $_ } @missing) + . " to be implemented by '$class_name'"); + } + } + elsif($args->{_to} eq 'role'){ + # apply role($role) to role($class) + foreach my $method_name($role->get_required_method_list){ + next if $class->has_method($method_name); # already has it + $class->add_required_methods($method_name); + } } return; @@ -76,26 +138,15 @@ sub _apply_methods{ my $role_name = $role->name; my $class_name = $class->name; - my $alias = (exists $args->{alias} && !exists $args->{-alias}) ? $args->{alias} : $args->{-alias}; - my $excludes = (exists $args->{excludes} && !exists $args->{-excludes}) ? $args->{excludes} : $args->{-excludes}; - - my %exclude_map; - - if(defined $excludes){ - if(ref $excludes){ - %exclude_map = map{ $_ => undef } @{$excludes}; - } - else{ - $exclude_map{$excludes} = undef; - } - } + my $alias = $args->{-alias}; + my $excludes = $args->{-excludes}; foreach my $method_name($role->get_method_list){ next if $method_name eq 'meta'; my $code = $role_name->can($method_name); - if(!exists $exclude_map{$method_name}){ + if(!exists $excludes->{$method_name}){ if(!$class->has_method($method_name)){ $class->add_method($method_name => $code); } @@ -104,8 +155,9 @@ sub _apply_methods{ if($alias && $alias->{$method_name}){ my $dstname = $alias->{$method_name}; - my $slot = do{ no strict 'refs'; \*{$class_name . '::' . $dstname} }; - if(defined(*{$slot}{CODE}) && *{$slot}{CODE} != $code){ + my $dstcode = do{ no strict 'refs'; *{$class_name . '::' . $dstname}{CODE} }; + + if(defined($dstcode) && $dstcode != $code){ $class->throw_error("Cannot create a method alias if a local method of the same name exists"); } else{ @@ -120,7 +172,7 @@ sub _apply_methods{ sub _apply_attributes{ my($role, $class, $args) = @_; - if ($class->isa('Mouse::Meta::Class')) { + if ($args->{_to} eq 'class') { # apply role to class for my $attr_name ($role->get_attribute_list) { next if $class->has_attribute($attr_name); @@ -137,7 +189,8 @@ sub _apply_attributes{ $attr_metaclass->create($class, $attr_name => %$spec); } - } else { + } + elsif($args->{_to} eq 'role'){ # apply role to role for my $attr_name ($role->get_attribute_list) { next if $class->has_attribute($attr_name); @@ -153,7 +206,7 @@ sub _apply_attributes{ sub _apply_modifiers{ my($role, $class, $args) = @_; - for my $modifier_type (qw/before after around override/) { + for my $modifier_type (qw/override before around after/) { my $add_modifier = "add_${modifier_type}_method_modifier"; my $modifiers = $role->{"${modifier_type}_method_modifiers"}; @@ -169,7 +222,7 @@ sub _apply_modifiers{ sub _append_roles{ my($role, $class, $args) = @_; - my $roles = $class->isa('Mouse::Meta::Class') ? $class->roles : $class->get_roles; + my $roles = ($args->{_to} eq 'class') ? $class->roles : $class->get_roles; foreach my $r($role, @{$role->get_roles}){ if(!$class->does_role($r->name)){ @@ -181,23 +234,26 @@ sub _append_roles{ # Moose uses Application::ToInstance, Application::ToClass, Application::ToRole sub apply { - my($self, $class, %args) = @_; + my $self = shift; + my $applicant = shift; - if ($class->isa('Mouse::Object')) { - not_supported 'Application::ToInstance'; - } + my $args = $self->_canonicalize_apply_args($applicant, @_); - $self->_check_required_methods($class, \%args); - $self->_apply_methods($class, \%args); - $self->_apply_attributes($class, \%args); - $self->_apply_modifiers($class, \%args); - $self->_append_roles($class, \%args); + $self->_check_required_methods($applicant, $args); + $self->_apply_methods($applicant, $args); + $self->_apply_attributes($applicant, $args); + $self->_apply_modifiers($applicant, $args); + $self->_append_roles($applicant, $args); return; } sub combine_apply { my(undef, $class, @roles) = @_; + if($class->isa('Mouse::Object')){ + not_supported 'Application::ToInstance'; + } + # check conflicting my %method_provided; my @method_conflicts; @@ -282,6 +338,8 @@ sub combine_apply { my $role = $role_name->meta; + $args = $role->_canonicalize_apply_args($class, %{$args}); + $role->_check_required_methods($class, $args, @roles); $role->_apply_methods($class, $args); $role->_apply_attributes($class, $args); diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm index f9f2181..da769b5 100644 --- a/lib/Mouse/Util.pm +++ b/lib/Mouse/Util.pm @@ -27,13 +27,13 @@ our %EXPORT_TAGS = ( # Moose::Util compatible utilities sub find_meta{ - return Mouse::Module::class_of( $_[0] ); + return Mouse::Meta::Module::class_of( $_[0] ); } sub does_role{ my ($class_or_obj, $role) = @_; - my $meta = Mouse::Module::class_of($class_or_obj); + my $meta = Mouse::Meta::Module::class_of($class_or_obj); return 0 unless defined $meta; return 1 if $meta->does_role($role); diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm index 8df17ea..a012e9d 100644 --- a/lib/Mouse/Util/TypeConstraints.pm +++ b/lib/Mouse/Util/TypeConstraints.pm @@ -103,8 +103,20 @@ sub type { } sub subtype { - my $pkg = caller(0); - my($name, %conf) = @_; + my $pkg = caller; + + my $name; + my %conf; + + if(@_ % 2){ # odd number of arguments + $name = shift; + %conf = @_; + } + else{ + %conf = @_; + $name = $conf{name} || '__ANON__'; + } + if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) { Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg"; }; diff --git a/t/030_roles/004_role_composition_errors.t b/t/030_roles/004_role_composition_errors.t new file mode 100644 index 0000000..837af9f --- /dev/null +++ b/t/030_roles/004_role_composition_errors.t @@ -0,0 +1,157 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 14; +use Test::Exception; + + + +{ + + package Foo::Role; + use Mouse::Role; + + requires 'foo'; +} + +is_deeply( + [ sort Foo::Role->meta->get_required_method_list ], + ['foo'], + '... the Foo::Role has a required method (foo)' +); + +# classes which does not implement required method +{ + + package Foo::Class; + use Mouse; + + ::dies_ok { with('Foo::Role') } + '... no foo method implemented by Foo::Class'; +} + +# class which does implement required method +{ + + package Bar::Class; + use Mouse; + + ::dies_ok { with('Foo::Class') } + '... cannot consume a class, it must be a role'; + ::lives_ok { with('Foo::Role') } + '... has a foo method implemented by Bar::Class'; + + sub foo {'Bar::Class::foo'} +} + +# role which does implement required method +{ + + package Bar::Role; + use Mouse::Role; + + ::lives_ok { with('Foo::Role') } + '... has a foo method implemented by Bar::Role'; + + sub foo {'Bar::Role::foo'} +} + +is_deeply( + [ sort Bar::Role->meta->get_required_method_list ], + [], + '... the Bar::Role has not inherited the required method from Foo::Role' +); + +# role which does not implement required method +{ + + package Baz::Role; + use Mouse::Role; + + ::lives_ok { with('Foo::Role') } + '... no foo method implemented by Baz::Role'; +} + +is_deeply( + [ sort Baz::Role->meta->get_required_method_list ], + ['foo'], + '... the Baz::Role has inherited the required method from Foo::Role' +); + +# classes which does not implement required method +{ + + package Baz::Class; + use Mouse; + + ::dies_ok { with('Baz::Role') } + '... no foo method implemented by Baz::Class2'; +} + +# class which does implement required method +{ + + package Baz::Class2; + use Mouse; + + ::lives_ok { with('Baz::Role') } + '... has a foo method implemented by Baz::Class2'; + + sub foo {'Baz::Class2::foo'} +} + + +{ + package Quux::Role; + use Mouse::Role; + + requires qw( meth1 meth2 meth3 meth4 ); +} + +# RT #41119 +{ + + package Quux::Class; + use Mouse; + + ::throws_ok { with('Quux::Role') } + qr/\Q'Quux::Role' requires the methods 'meth1', 'meth2', 'meth3', and 'meth4' to be implemented by 'Quux::Class'/, + 'exception mentions all the missing required methods at once'; +} + +{ + package Quux::Class2; + use Mouse; + + sub meth1 { } + + ::throws_ok { with('Quux::Role') } + qr/'Quux::Role' requires the methods 'meth2', 'meth3', and 'meth4' to be implemented by 'Quux::Class2'/, + 'exception mentions all the missing required methods at once, but not the one that exists'; +} + +{ + package Quux::Class3; + use Mouse; + + has 'meth1' => ( is => 'ro' ); + has 'meth2' => ( is => 'ro' ); + + ::throws_ok { with('Quux::Role') } + qr/'Quux::Role' requires the methods 'meth3' and 'meth4' to be implemented by 'Quux::Class3'/, + 'exception mentions all the missing methods at once, but not the accessors'; +} + +{ + package Quux::Class4; + use Mouse; + + sub meth1 { } + has 'meth2' => ( is => 'ro' ); + + ::throws_ok { with('Quux::Role') } + qr/'Quux::Role' requires the methods 'meth3' and 'meth4' to be implemented by 'Quux::Class4'/, + 'exception mentions all the require methods that are accessors at once, as well as missing methods, but not the one that exists'; +} diff --git a/t/030_roles/034_create_role.t b/t/030_roles/034_create_role.t new file mode 100644 index 0000000..25645d7 --- /dev/null +++ b/t/030_roles/034_create_role.t @@ -0,0 +1,32 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 4; +use Mouse (); + +my $role = Mouse::Meta::Role->create( + 'MyItem::Role::Equipment', + attributes => { + is_worn => { + is => 'rw', + isa => 'Bool', + }, + }, + methods => { + remove => sub { shift->is_worn(0) }, + }, +); + +my $class = Mouse::Meta::Class->create('MyItem::Armor::Helmet' => + roles => ['MyItem::Role::Equipment'], +); + +my $visored = $class->new_object(is_worn => 0); +ok(!$visored->is_worn, "attribute, accessor was consumed"); +$visored->is_worn(1); +ok($visored->is_worn, "accessor was consumed"); +$visored->remove; +ok(!$visored->is_worn, "method was consumed"); + +ok(!$role->is_anon_role, "the role is not anonymous"); + diff --git a/t/030_roles/035_anonymous_roles.t b/t/030_roles/035_anonymous_roles.t new file mode 100644 index 0000000..08428df --- /dev/null +++ b/t/030_roles/035_anonymous_roles.t @@ -0,0 +1,35 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 7; +use Mouse (); + +my $role = Mouse::Meta::Role->create_anon_role( + attributes => { + is_worn => { + is => 'rw', + isa => 'Bool', + }, + }, + methods => { + remove => sub { shift->is_worn(0) }, + }, +); + +my $class = Mouse::Meta::Class->create('MyItem::Armor::Helmet'); +$role->apply($class); +# XXX: Mouse::Util::apply_all_roles doesn't cope with references yet + +my $visored = $class->new_object(is_worn => 0); +ok(!$visored->is_worn, "attribute, accessor was consumed"); +$visored->is_worn(1); +ok($visored->is_worn, "accessor was consumed"); +$visored->remove; +ok(!$visored->is_worn, "method was consumed"); + +like($role->name, qr/::__ANON__::/, "the role name (is " . $role->name . ")"); +ok($role->is_anon_role, "the role knows it's anonymous"); + +ok(Mouse::Util::is_class_loaded(Mouse::Meta::Role->create_anon_role->name), "creating an anonymous role satisifes is_class_loaded"); +ok(Mouse::Util::find_meta(Mouse::Meta::Role->create_anon_role->name), "creating an anonymous role satisifes class_of"); + diff --git a/t/030_roles/036_free_anonymous_roles.t b/t/030_roles/036_free_anonymous_roles.t new file mode 100644 index 0000000..7429765 --- /dev/null +++ b/t/030_roles/036_free_anonymous_roles.t @@ -0,0 +1,34 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More tests => 4; +use Mouse (); +use Scalar::Util 'weaken'; + +my $weak; +my $name; +do { + my $anon_class; + + do { + my $role = Mouse::Meta::Role->create_anon_role( + methods => { + improperly_freed => sub { 1 }, + }, + ); + weaken($weak = $role); + + $name = $role->name; + + $anon_class = Mouse::Meta::Class->create_anon_class( + roles => [ $role->name ], + ); + }; + + ok($weak, "we still have the role metaclass because the anonymous class that consumed it is still alive"); + ok($name->can('improperly_freed'), "we have not blown away the role's symbol table"); +}; + +ok(!$weak, "the role metaclass is freed after its last reference (from a consuming anonymous class) is freed"); + +ok(!$name->can('improperly_freed'), "we blew away the role's symbol table entries"); diff --git a/t/030_roles/failing/012_method_exclusion_in_composition.t b/t/030_roles/failing/012_method_exclusion_in_composition.t index d852b17..f678d2c 100644 --- a/t/030_roles/failing/012_method_exclusion_in_composition.t +++ b/t/030_roles/failing/012_method_exclusion_in_composition.t @@ -39,7 +39,7 @@ ok(My::OtherRole->meta->has_method($_), "we have a $_ method") for qw(foo bar ba ok(!My::OtherRole->meta->requires_method('foo'), '... and the &foo method is not required'); ok(My::OtherRole->meta->requires_method('bar'), '... and the &bar method is required'); - +use Data::Dumper; print Dumper(My::OtherRole->meta->{required_methods}); { package Foo::Role; use Mouse::Role; diff --git a/t/030_roles/failing/037_create_role_subclass.t b/t/030_roles/failing/037_create_role_subclass.t index 11e9105..d794e12 100644 --- a/t/030_roles/failing/037_create_role_subclass.t +++ b/t/030_roles/failing/037_create_role_subclass.t @@ -19,6 +19,7 @@ do { }; my $role = My::Meta::Role->create_anon_role; +#use Data::Dumper; $Data::Dumper::Deparse = 1; print Dumper $role->can('test_serial'); is($role->test_serial, 1, "default value for the serial attribute"); my $nine_role = My::Meta::Role->create_anon_role(test_serial => 9); diff --git a/t/200_examples/001_example.t b/t/200_examples/001_example.t new file mode 100644 index 0000000..b4606c4 --- /dev/null +++ b/t/200_examples/001_example.t @@ -0,0 +1,128 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 20; +use Test::Exception; + + + +## Roles + +{ + package Constraint; + use Mouse::Role; + + has 'value' => (isa => 'Num', is => 'ro'); + + around 'validate' => sub { + my $c = shift; + my ($self, $field) = @_; + return undef if $c->($self, $self->validation_value($field)); + return $self->error_message; + }; + + sub validation_value { + my ($self, $field) = @_; + return $field; + } + + sub error_message { confess "Abstract method!" } + + package Constraint::OnLength; + use Mouse::Role; + + has 'units' => (isa => 'Str', is => 'ro'); + + override 'validation_value' => sub { + return length(super()); + }; + + override 'error_message' => sub { + my $self = shift; + return super() . ' ' . $self->units; + }; + +} + +## Classes + +{ + package Constraint::AtLeast; + use Mouse; + + with 'Constraint'; + + sub validate { + my ($self, $field) = @_; + ($field >= $self->value); + } + + sub error_message { 'must be at least ' . (shift)->value; } + + package Constraint::NoMoreThan; + use Mouse; + + with 'Constraint'; + + sub validate { + my ($self, $field) = @_; + ($field <= $self->value); + } + + sub error_message { 'must be no more than ' . (shift)->value; } + + package Constraint::LengthNoMoreThan; + use Mouse; + + extends 'Constraint::NoMoreThan'; + with 'Constraint::OnLength'; + + package Constraint::LengthAtLeast; + use Mouse; + + extends 'Constraint::AtLeast'; + with 'Constraint::OnLength'; +} + +my $no_more_than_10 = Constraint::NoMoreThan->new(value => 10); +isa_ok($no_more_than_10, 'Constraint::NoMoreThan'); + +ok($no_more_than_10->does('Constraint'), '... Constraint::NoMoreThan does Constraint'); + +ok(!defined($no_more_than_10->validate(1)), '... validated correctly'); +is($no_more_than_10->validate(11), 'must be no more than 10', '... validation failed correctly'); + +my $at_least_10 = Constraint::AtLeast->new(value => 10); +isa_ok($at_least_10, 'Constraint::AtLeast'); + +ok($at_least_10->does('Constraint'), '... Constraint::AtLeast does Constraint'); + +ok(!defined($at_least_10->validate(11)), '... validated correctly'); +is($at_least_10->validate(1), 'must be at least 10', '... validation failed correctly'); + +# onlength + +my $no_more_than_10_chars = Constraint::LengthNoMoreThan->new(value => 10, units => 'chars'); +isa_ok($no_more_than_10_chars, 'Constraint::LengthNoMoreThan'); +isa_ok($no_more_than_10_chars, 'Constraint::NoMoreThan'); + +ok($no_more_than_10_chars->does('Constraint'), '... Constraint::LengthNoMoreThan does Constraint'); +ok($no_more_than_10_chars->does('Constraint::OnLength'), '... Constraint::LengthNoMoreThan does Constraint::OnLength'); + +ok(!defined($no_more_than_10_chars->validate('foo')), '... validated correctly'); +is($no_more_than_10_chars->validate('foooooooooo'), + 'must be no more than 10 chars', + '... validation failed correctly'); + +my $at_least_10_chars = Constraint::LengthAtLeast->new(value => 10, units => 'chars'); +isa_ok($at_least_10_chars, 'Constraint::LengthAtLeast'); +isa_ok($at_least_10_chars, 'Constraint::AtLeast'); + +ok($at_least_10_chars->does('Constraint'), '... Constraint::LengthAtLeast does Constraint'); +ok($at_least_10_chars->does('Constraint::OnLength'), '... Constraint::LengthAtLeast does Constraint::OnLength'); + +ok(!defined($at_least_10_chars->validate('barrrrrrrrr')), '... validated correctly'); +is($at_least_10_chars->validate('bar'), 'must be at least 10 chars', '... validation failed correctly'); + diff --git a/t/200_examples/003_example.t b/t/200_examples/003_example.t new file mode 100644 index 0000000..879fc3b --- /dev/null +++ b/t/200_examples/003_example.t @@ -0,0 +1,163 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 30; +use Test::Exception; + +sub U { + my $f = shift; + sub { $f->($f, @_) }; +} + +sub Y { + my $f = shift; + U(sub { my $h = shift; sub { $f->(U($h)->())->(@_) } })->(); +} + +{ + package List; + use Mouse::Role; + + has '_list' => ( + is => 'ro', + isa => 'ArrayRef', + init_arg => '::', + default => sub { [] } + ); + + sub head { (shift)->_list->[0] } + sub tail { + my $self = shift; + (ref $self)->new( + '::' => [ + @{$self->_list}[1 .. $#{$self->_list}] + ] + ); + } + + sub print { + join ", " => @{$_[0]->_list}; + } + + package List::Immutable; + use Mouse::Role; + + requires 'head'; + requires 'tail'; + + sub is_empty { not defined ($_[0]->head) } + + sub length { + my $self = shift; + (::Y(sub { + my $redo = shift; + sub { + my ($list, $acc) = @_; + return $acc if $list->is_empty; + $redo->($list->tail, $acc + 1); + } + }))->($self, 0); + } + + sub apply { + my ($self, $function) = @_; + (::Y(sub { + my $redo = shift; + sub { + my ($list, $func, $acc) = @_; + return (ref $list)->new('::' => $acc) + if $list->is_empty; + $redo->( + $list->tail, + $func, + [ @{$acc}, $func->($list->head) ] + ); + } + }))->($self, $function, []); + } + + package My::List1; + use Mouse; + + ::lives_ok { + with 'List', 'List::Immutable'; + } '... successfully composed roles together'; + + package My::List2; + use Mouse; + + ::lives_ok { + with 'List::Immutable', 'List'; + } '... successfully composed roles together'; + +} + +{ + my $coll = My::List1->new; + isa_ok($coll, 'My::List1'); + + ok($coll->does('List'), '... $coll does List'); + ok($coll->does('List::Immutable'), '... $coll does List::Immutable'); + + ok($coll->is_empty, '... we have an empty collection'); + is($coll->length, 0, '... we have a length of 1 for the collection'); +} + +{ + my $coll = My::List2->new; + isa_ok($coll, 'My::List2'); + + ok($coll->does('List'), '... $coll does List'); + ok($coll->does('List::Immutable'), '... $coll does List::Immutable'); + + ok($coll->is_empty, '... we have an empty collection'); + is($coll->length, 0, '... we have a length of 1 for the collection'); +} + +{ + my $coll = My::List1->new('::' => [ 1 .. 10 ]); + isa_ok($coll, 'My::List1'); + + ok($coll->does('List'), '... $coll does List'); + ok($coll->does('List::Immutable'), '... $coll does List::Immutable'); + + ok(!$coll->is_empty, '... we do not have an empty collection'); + is($coll->length, 10, '... we have a length of 10 for the collection'); + + is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... got the right printed value'); + + my $coll2 = $coll->apply(sub { $_[0] * $_[0] }); + isa_ok($coll2, 'My::List1'); + + is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... original is still the same'); + is($coll2->print, '1, 4, 9, 16, 25, 36, 49, 64, 81, 100', '... new collection is changed'); +} + +{ + my $coll = My::List2->new('::' => [ 1 .. 10 ]); + isa_ok($coll, 'My::List2'); + + ok($coll->does('List'), '... $coll does List'); + ok($coll->does('List::Immutable'), '... $coll does List::Immutable'); + + ok(!$coll->is_empty, '... we do not have an empty collection'); + is($coll->length, 10, '... we have a length of 10 for the collection'); + + is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... got the right printed value'); + + my $coll2 = $coll->apply(sub { $_[0] * $_[0] }); + isa_ok($coll2, 'My::List2'); + + is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... original is still the same'); + is($coll2->print, '1, 4, 9, 16, 25, 36, 49, 64, 81, 100', '... new collection is changed'); +} + + + + + + + + diff --git a/t/200_examples/004_example_w_DCS.t b/t/200_examples/004_example_w_DCS.t new file mode 100644 index 0000000..00e8dce --- /dev/null +++ b/t/200_examples/004_example_w_DCS.t @@ -0,0 +1,92 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +=pod + +This tests how well Mouse type constraints +play with Declare::Constraints::Simple. + +Pretty well if I do say so myself :) + +=cut + +BEGIN { + eval "use Declare::Constraints::Simple;"; + plan skip_all => "Declare::Constraints::Simple is required for this test" if $@; + plan tests => 9; +} + +use Test::Exception; + +{ + package Foo; + use Mouse; + use Mouse::Util::TypeConstraints; + use Declare::Constraints::Simple -All; + + # define your own type ... + type( 'HashOfArrayOfObjects', + where => IsHashRef( + -keys => HasLength, + -values => IsArrayRef(IsObject) + ) + ); + + has 'bar' => ( + is => 'rw', + isa => 'HashOfArrayOfObjects', + ); + + # inline the constraints as anon-subtypes + has 'baz' => ( + is => 'rw', + isa => subtype( as => 'ArrayRef', where => IsArrayRef(IsInt) ), + ); + + package Bar; + use Mouse; +} + +my $hash_of_arrays_of_objs = { + foo1 => [ Bar->new ], + foo2 => [ Bar->new, Bar->new ], +}; + +my $array_of_ints = [ 1 .. 10 ]; + +my $foo; +lives_ok { + $foo = Foo->new( + 'bar' => $hash_of_arrays_of_objs, + 'baz' => $array_of_ints, + ); +} '... construction succeeded'; +isa_ok($foo, 'Foo'); + +is_deeply($foo->bar, $hash_of_arrays_of_objs, '... got our value correctly'); +is_deeply($foo->baz, $array_of_ints, '... got our value correctly'); + +dies_ok { + $foo->bar([]); +} '... validation failed correctly'; + +dies_ok { + $foo->bar({ foo => 3 }); +} '... validation failed correctly'; + +dies_ok { + $foo->bar({ foo => [ 1, 2, 3 ] }); +} '... validation failed correctly'; + + +dies_ok { + $foo->baz([ "foo" ]); +} '... validation failed correctly'; + +dies_ok { + $foo->baz({}); +} '... validation failed correctly'; diff --git a/t/200_examples/005_example_w_TestDeep.t b/t/200_examples/005_example_w_TestDeep.t new file mode 100644 index 0000000..604b78f --- /dev/null +++ b/t/200_examples/005_example_w_TestDeep.t @@ -0,0 +1,78 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +=pod + +This tests how well Mouse type constraints +play with Test::Deep. + +Its not as pretty as Declare::Constraints::Simple, +but it is not completely horrid either. + +=cut + +BEGIN { + eval "use Test::Deep;"; + plan skip_all => "Test::Deep is required for this test" if $@; + plan tests => 5; +} + +use Test::Exception; + +{ + package Foo; + use Mouse; + use Mouse::Util::TypeConstraints; + + use Test::Deep qw[ + eq_deeply array_each subhashof ignore + ]; + + # define your own type ... + type 'ArrayOfHashOfBarsAndRandomNumbers' + => where { + eq_deeply($_, + array_each( + subhashof({ + bar => Test::Deep::isa('Bar'), + random_number => ignore() + }) + ) + ) + }; + + has 'bar' => ( + is => 'rw', + isa => 'ArrayOfHashOfBarsAndRandomNumbers', + ); + + package Bar; + use Mouse; +} + +my $array_of_hashes = [ + { bar => Bar->new, random_number => 10 }, + { bar => Bar->new }, +]; + +my $foo; +lives_ok { + $foo = Foo->new('bar' => $array_of_hashes); +} '... construction succeeded'; +isa_ok($foo, 'Foo'); + +is_deeply($foo->bar, $array_of_hashes, '... got our value correctly'); + +dies_ok { + $foo->bar({}); +} '... validation failed correctly'; + +dies_ok { + $foo->bar([{ foo => 3 }]); +} '... validation failed correctly'; + + diff --git a/t/200_examples/007_Child_Parent_attr_inherit.t b/t/200_examples/007_Child_Parent_attr_inherit.t new file mode 100644 index 0000000..e41a568 --- /dev/null +++ b/t/200_examples/007_Child_Parent_attr_inherit.t @@ -0,0 +1,136 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 23; + +=pod + +Some examples of triggers and how they can +be used to manage parent-child relationships. + +=cut + +{ + + package Parent; + use Mouse; + + has 'last_name' => ( + is => 'rw', + isa => 'Str', + trigger => sub { + my $self = shift; + + # if the parents last-name changes + # then so do all the childrens + foreach my $child ( @{ $self->children } ) { + $child->last_name( $self->last_name ); + } + } + ); + + has 'children' => + ( is => 'rw', isa => 'ArrayRef', default => sub { [] } ); +} +{ + + package Child; + use Mouse; + + has 'parent' => ( + is => 'rw', + isa => 'Parent', + required => 1, + trigger => sub { + my $self = shift; + + # if the parent is changed,.. + # make sure we update + $self->last_name( $self->parent->last_name ); + } + ); + + has 'last_name' => ( + is => 'rw', + isa => 'Str', + lazy => 1, + default => sub { (shift)->parent->last_name } + ); + +} + +my $parent = Parent->new( last_name => 'Smith' ); +isa_ok( $parent, 'Parent' ); + +is( $parent->last_name, 'Smith', + '... the parent has the last name we expected' ); + +$parent->children( [ map { Child->new( parent => $parent ) } ( 0 .. 3 ) ] ); + +foreach my $child ( @{ $parent->children } ) { + is( $child->last_name, $parent->last_name, + '... parent and child have the same last name (' + . $parent->last_name + . ')' ); +} + +$parent->last_name('Jones'); +is( $parent->last_name, 'Jones', '... the parent has the new last name' ); + +foreach my $child ( @{ $parent->children } ) { + is( $child->last_name, $parent->last_name, + '... parent and child have the same last name (' + . $parent->last_name + . ')' ); +} + +# make a new parent + +my $parent2 = Parent->new( last_name => 'Brown' ); +isa_ok( $parent2, 'Parent' ); + +# orphan the child + +my $orphan = pop @{ $parent->children }; + +# and then the new parent adopts it + +$orphan->parent($parent2); + +foreach my $child ( @{ $parent->children } ) { + is( $child->last_name, $parent->last_name, + '... parent and child have the same last name (' + . $parent->last_name + . ')' ); +} + +isnt( $orphan->last_name, $parent->last_name, + '... the orphan child does not have the same last name anymore (' + . $parent2->last_name + . ')' ); +is( $orphan->last_name, $parent2->last_name, + '... parent2 and orphan child have the same last name (' + . $parent2->last_name + . ')' ); + +# make sure that changes still will not propagate + +$parent->last_name('Miller'); +is( $parent->last_name, 'Miller', + '... the parent has the new last name (again)' ); + +foreach my $child ( @{ $parent->children } ) { + is( $child->last_name, $parent->last_name, + '... parent and child have the same last name (' + . $parent->last_name + . ')' ); +} + +isnt( $orphan->last_name, $parent->last_name, + '... the orphan child is not affected by changes in the parent anymore' ); +is( $orphan->last_name, $parent2->last_name, + '... parent2 and orphan child have the same last name (' + . $parent2->last_name + . ')' ); diff --git a/t/200_examples/008_record_set_iterator.t b/t/200_examples/008_record_set_iterator.t new file mode 100644 index 0000000..aebe61c --- /dev/null +++ b/t/200_examples/008_record_set_iterator.t @@ -0,0 +1,127 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 8; +use Test::Exception; + + + +{ + package Record; + use Mouse; + + has 'first_name' => (is => 'ro', isa => 'Str'); + has 'last_name' => (is => 'ro', isa => 'Str'); + + package RecordSet; + use Mouse; + + has 'data' => ( + is => 'ro', + isa => 'ArrayRef[Record]', + default => sub { [] }, + ); + + has 'index' => ( + is => 'rw', + isa => 'Int', + default => sub { 0 }, + ); + + sub next { + my $self = shift; + my $i = $self->index; + $self->index($i + 1); + return $self->data->[$i]; + } + + package RecordSetIterator; + use Mouse; + + has 'record_set' => ( + is => 'rw', + isa => 'RecordSet', + ); + + # list the fields you want to + # fetch from the current record + my @fields = Record->meta->get_attribute_list; + + has 'current_record' => ( + is => 'rw', + isa => 'Record', + lazy => 1, + default => sub { + my $self = shift; + $self->record_set->next() # grab the first one + }, + trigger => sub { + my $self = shift; + # whenever this attribute is + # updated, it will clear all + # the fields for you. + $self->$_() for map { '_clear_' . $_ } @fields; + } + ); + + # define the attributes + # for all the fields. + for my $field (@fields) { + has $field => ( + is => 'ro', + isa => 'Any', + lazy => 1, + default => sub { + my $self = shift; + # fetch the value from + # the current record + $self->current_record->$field(); + }, + # make sure they have a clearer .. + clearer => ('_clear_' . $field) + ); + } + + sub get_next_record { + my $self = shift; + $self->current_record($self->record_set->next()); + } +} + +my $rs = RecordSet->new( + data => [ + Record->new(first_name => 'Bill', last_name => 'Smith'), + Record->new(first_name => 'Bob', last_name => 'Jones'), + Record->new(first_name => 'Jim', last_name => 'Johnson'), + ] +); +isa_ok($rs, 'RecordSet'); + +my $rsi = RecordSetIterator->new(record_set => $rs); +isa_ok($rsi, 'RecordSetIterator'); + +is($rsi->first_name, 'Bill', '... got the right first name'); +is($rsi->last_name, 'Smith', '... got the right last name'); + +$rsi->get_next_record; + +is($rsi->first_name, 'Bob', '... got the right first name'); +is($rsi->last_name, 'Jones', '... got the right last name'); + +$rsi->get_next_record; + +is($rsi->first_name, 'Jim', '... got the right first name'); +is($rsi->last_name, 'Johnson', '... got the right last name'); + + + + + + + + + + + diff --git a/t/400_mouse_util/002_mouse_util_does_role.t b/t/400_mouse_util/002_mouse_util_does_role.t new file mode 100644 index 0000000..5447418 --- /dev/null +++ b/t/400_mouse_util/002_mouse_util_does_role.t @@ -0,0 +1,81 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 8; + +BEGIN { + use_ok('Mouse::Util', ':all'); +} + +{ + package Foo; + + use Mouse::Role; +} + +{ + package Bar; + + use Mouse; + + with qw/Foo/; +} + +{ + package Baz; + + use Mouse; +} + +{ + package Quux; + + use metaclass; +} + +{ + package Foo::Foo; + + use Mouse::Role; + + with 'Foo'; +} + +# Classes + +ok(does_role('Bar', 'Foo'), '... Bar does Foo'); + +ok(!does_role('Baz', 'Foo'), '... Baz doesnt do Foo'); + +# Objects + +my $bar = Bar->new; + +ok(does_role($bar, 'Foo'), '... $bar does Foo'); + +my $baz = Baz->new; + +ok(!does_role($baz, 'Foo'), '... $baz doesnt do Foo'); + +# Invalid values + +ok(!does_role(undef,'Foo'), '... undef doesnt do Foo'); + +ok(!does_role(1,'Foo'), '... 1 doesnt do Foo'); + +# non Mouse metaclass + +ok(!does_role('Quux', 'Foo'), '... Quux doesnt do Foo (does not die tho)'); + +# TODO: make the below work, maybe? + +# Self + +#ok(does_role('Foo', 'Foo'), '... Foo does do Foo'); + +# sub-Roles + +#ok(does_role('Foo::Foo', 'Foo'), '... Foo::Foo does do Foo'); + diff --git a/t/lib/Test/Mouse.pm b/t/lib/Test/Mouse.pm index 83a5ca0..14f20ef 100644 --- a/t/lib/Test/Mouse.pm +++ b/t/lib/Test/Mouse.pm @@ -2,6 +2,7 @@ package Test::Mouse; use strict; use warnings; +use Carp qw(croak); use Mouse::Util qw(find_meta does_role); use base qw(Test::Builder::Module); @@ -24,6 +25,9 @@ sub meta_ok ($;$) { sub does_ok ($$;$) { my ($class_or_obj, $does, $message) = @_; + if(!defined $does){ + croak "You must pass a role name"; + } $message ||= "The object does $does"; if (does_ok($class_or_obj)) {