From: gfx Date: Thu, 24 Sep 2009 00:56:23 +0000 (+0900) Subject: Add some tests X-Git-Tag: 0.35~33^2~9 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=8e64d0fa5da64639074f77d3da9b2f7aa20cce93 Add some tests --- diff --git a/.shipit b/.shipit index d0355ce..eed06f7 100644 --- a/.shipit +++ b/.shipit @@ -1,7 +1,7 @@ -# auto-generated shipit config file. -steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist - -git.tagpattern = %v -git.push_to = origin - -CheckChangeLog.files = Changes +# auto-generated shipit config file. +steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist + +git.tagpattern = %v +git.push_to = origin + +CheckChangeLog.files = Changes diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm index 46b4a15..c1e614a 100644 --- a/lib/Mouse/Meta/Class.pm +++ b/lib/Mouse/Meta/Class.pm @@ -14,7 +14,7 @@ use base qw(Mouse::Meta::Module); sub method_metaclass(){ 'Mouse::Meta::Method' } # required for get_method() -sub _new { +sub _construct_meta { my($class, %args) = @_; $args{attributes} ||= {}; @@ -29,7 +29,7 @@ sub _new { #return Mouse::Meta::Class->initialize($class)->new_object(%args) # if $class ne __PACKAGE__; - return bless \%args, $class; + return bless \%args, ref($class) || $class; } sub create_anon_class{ @@ -51,7 +51,23 @@ sub superclasses { @{ $self->{superclasses} } = @_; } - @{ $self->{superclasses} }; + return @{ $self->{superclasses} }; +} + +sub find_method_by_name{ + my($self, $method_name) = @_; + defined($method_name) + or $self->throw_error('You must define a method name to find'); + foreach my $class( $self->linearized_isa ){ + my $method = $self->initialize($class)->get_method($method_name); + return $method if defined $method; + } + return undef; +} + +sub get_all_methods { + my($self) = @_; + return map{ $self->find_method_by_name($self) } $self->get_all_method_names; } sub get_all_method_names { diff --git a/lib/Mouse/Meta/Method.pm b/lib/Mouse/Meta/Method.pm index 763e532..a423012 100755 --- a/lib/Mouse/Meta/Method.pm +++ b/lib/Mouse/Meta/Method.pm @@ -1,23 +1,23 @@ -package Mouse::Meta::Method; -use strict; -use warnings; - -use overload - '&{}' => 'body', - fallback => 1, -; - -sub new{ - my($class, %args) = @_; - - return bless \%args, $class; -} - -sub body { $_[0]->{body} } -sub name { $_[0]->{name} } -sub package{ $_[0]->{name} } - - -1; - -__END__ +package Mouse::Meta::Method; +use strict; +use warnings; + +use overload + '&{}' => 'body', + fallback => 1, +; + +sub new{ + my($class, %args) = @_; + + return bless \%args, $class; +} + +sub body { $_[0]->{body} } +sub name { $_[0]->{name} } +sub package_name{ $_[0]->{package} } + + +1; + +__END__ diff --git a/lib/Mouse/Meta/Method/Accessor.pm b/lib/Mouse/Meta/Method/Accessor.pm index 0fb563c..4d7e3a9 100755 --- a/lib/Mouse/Meta/Method/Accessor.pm +++ b/lib/Mouse/Meta/Method/Accessor.pm @@ -171,22 +171,22 @@ sub _install_handles { foreach my $handle_name (keys %handles) { my $method_to_call = $handles{$handle_name}; - my $code = sub { - my $instance = shift; - my $proxy = $instance->$reader(); - - my $error = !defined($proxy) ? ' is not defined' - : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')} - : undef; + my $code = sub { + my $instance = shift; + my $proxy = $instance->$reader(); + + my $error = !defined($proxy) ? ' is not defined' + : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')} + : undef; if ($error) { - $instance->meta->throw_error( - "Cannot delegate $handle_name to $method_to_call because " - . "the value of " - . $attribute->name + $instance->meta->throw_error( + "Cannot delegate $handle_name to $method_to_call because " + . "the value of " + . $attribute->name . $error - ); - } - $proxy->$method_to_call(@_); + ); + } + $proxy->$method_to_call(@_); }; $class->add_method($handle_name => $code); } diff --git a/lib/Mouse/Meta/Module.pm b/lib/Mouse/Meta/Module.pm index 712e5e1..51e1a6d 100755 --- a/lib/Mouse/Meta/Module.pm +++ b/lib/Mouse/Meta/Module.pm @@ -20,11 +20,11 @@ use Mouse::Util qw/get_code_info not_supported load_class/; sub initialize { my($class, $package_name, @args) = @_; - ($package_name && !ref($package_name)) - || $class->throw_error("You must pass a package name and it cannot be blessed"); + ($package_name && !ref($package_name)) + || $class->throw_error("You must pass a package name and it cannot be blessed"); return $METACLASS_CACHE{$package_name} - ||= $class->_new(package => $package_name, @args); + ||= $class->_construct_meta(package => $package_name, @args); } sub class_of{ @@ -51,7 +51,6 @@ sub meta{ Mouse::Meta::Class->initialize(ref $_[0] || $_[0]) } sub _new{ Carp::croak("Mouse::Meta::Module is an abstract class") } sub name { $_[0]->{package} } -sub _method_map{ $_[0]->{methods} } sub version { no strict 'refs'; ${shift->name.'::VERSION'} } sub authority { no strict 'refs'; ${shift->name.'::AUTHORITY'} } @@ -88,7 +87,7 @@ sub add_method { not_supported 'add_method for a method object'; } - $self->_method_map->{$name}++; # Moose stores meta object here. + $self->{methods}->{$name}++; # Moose stores meta object here. my $pkg = $self->name; no strict 'refs'; @@ -96,19 +95,19 @@ sub add_method { *{ $pkg . '::' . $name } = $code; } -sub _code_is_mine { # taken from Class::MOP::Class - my ( $self, $code ) = @_; - - my ( $code_package, $code_name ) = get_code_info($code); - - return $code_package && $code_package eq $self->name - || ( $code_package eq 'constant' && $code_name eq '__ANON__' ); +sub _code_is_mine { # taken from Class::MOP::Class + my ( $self, $code ) = @_; + + my ( $code_package, $code_name ) = get_code_info($code); + + return $code_package && $code_package eq $self->name + || ( $code_package eq 'constant' && $code_name eq '__ANON__' ); } sub has_method { my($self, $method_name) = @_; - return 1 if $self->_method_map->{$method_name}; + return 1 if $self->{methods}->{$method_name}; my $code = $self->name->can($method_name); return $code && $self->_code_is_mine($code); @@ -132,10 +131,10 @@ sub get_method{ return undef; } -sub get_method_list { +sub get_method_list { my($self) = @_; - - return grep { $self->has_method($_) } keys %{ $self->namespace }; + + return grep { $self->has_method($_) } keys %{ $self->namespace }; } { @@ -185,10 +184,10 @@ sub get_method_list { # 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} || []}), + # 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}; } @@ -282,7 +281,7 @@ sub throw_error{ my($class, $message, %args) = @_; local $Carp::CarpLevel = $Carp::CarpLevel + 1 + ($args{depth} || 0); - local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though + local $Carp::MaxArgNums = 20; # default is 8, usually we use named args which gets messier though if(exists $args{longmess} && !$args{longmess}){ # intentionaly longmess => 0 Carp::croak($message); diff --git a/lib/Mouse/Meta/Role.pm b/lib/Mouse/Meta/Role.pm index 4b5c26f..aff399f 100644 --- a/lib/Mouse/Meta/Role.pm +++ b/lib/Mouse/Meta/Role.pm @@ -9,7 +9,7 @@ use base qw(Mouse::Meta::Module); sub method_metaclass(){ 'Mouse::Meta::Role::Method' } # required for get_method() -sub _new { +sub _construct_meta { my $class = shift; my %args = @_; @@ -22,7 +22,7 @@ sub _new { # return Mouse::Meta::Class->initialize($class)->new_object(%args) # if $class ne __PACKAGE__; - return bless \%args, $class; + return bless \%args, ref($class) || $class; } sub create_anon_role{ @@ -288,7 +288,7 @@ sub combine_apply { my $attr = $role->get_attribute($attr_name); my $c = $attr_provided{$attr_name}; if($c && $c != $attr){ - $class->throw_error("We have encountered an attribute conflict with '$attr_name' " + $class->throw_error("We have encountered an attribute conflict with '$attr_name' " . "during composition. This is fatal error and cannot be disambiguated.") } else{ @@ -301,8 +301,8 @@ sub combine_apply { my $override = $role->get_override_method_modifier($method_name); my $c = $override_provided{$method_name}; if($c && $c != $override){ - $class->throw_error( "We have encountered an 'override' method conflict with '$method_name' during " - . "composition (Two 'override' methods of the same name encountered). " + $class->throw_error( "We have encountered an 'override' method conflict with '$method_name' during " + . "composition (Two 'override' methods of the same name encountered). " . "This is fatal error.") } else{ @@ -382,7 +382,7 @@ sub add_override_method_modifier{ if($self->has_method($method_name)){ # This error happens in the override keyword or during role composition, # so I added a message, "A local method of ...", only for compatibility (gfx) - $self->throw_error("Cannot add an override of method '$method_name' " + $self->throw_error("Cannot add an override of method '$method_name' " . "because there is a local version of '$method_name'" . "(A local method of the same name as been found)"); } @@ -390,14 +390,14 @@ sub add_override_method_modifier{ $self->{override_method_modifiers}->{$method_name} = $method; } -sub has_override_method_modifier { - my ($self, $method_name) = @_; - return exists $self->{override_method_modifiers}->{$method_name}; -} - -sub get_override_method_modifier { - my ($self, $method_name) = @_; - return $self->{override_method_modifiers}->{$method_name}; +sub has_override_method_modifier { + my ($self, $method_name) = @_; + return exists $self->{override_method_modifiers}->{$method_name}; +} + +sub get_override_method_modifier { + my ($self, $method_name) = @_; + return $self->{override_method_modifiers}->{$method_name}; } sub get_method_modifier_list { diff --git a/lib/Mouse/Meta/Role/Method.pm b/lib/Mouse/Meta/Role/Method.pm index eb94651..1d3d0a0 100755 --- a/lib/Mouse/Meta/Role/Method.pm +++ b/lib/Mouse/Meta/Role/Method.pm @@ -1,10 +1,10 @@ -package Mouse::Meta::Role::Method; -use strict; -use warnings; - -use base qw(Mouse::Meta::Method); - -1; - -__END__ - +package Mouse::Meta::Role::Method; +use strict; +use warnings; + +use base qw(Mouse::Meta::Method); + +1; + +__END__ + diff --git a/lib/Mouse/Meta/TypeConstraint.pm b/lib/Mouse/Meta/TypeConstraint.pm index 916acc1..30b0f06 100644 --- a/lib/Mouse/Meta/TypeConstraint.pm +++ b/lib/Mouse/Meta/TypeConstraint.pm @@ -34,23 +34,23 @@ sub check { } sub validate { - my ($self, $value) = @_; - if ($self->{_compiled_type_constraint}->($value)) { - return undef; - } - else { - $self->get_message($value); - } + my ($self, $value) = @_; + if ($self->{_compiled_type_constraint}->($value)) { + return undef; + } + else { + $self->get_message($value); + } } -sub assert_valid { - my ($self, $value) = @_; - - my $error = $self->validate($value); - return 1 if ! defined $error; +sub assert_valid { + my ($self, $value) = @_; + + my $error = $self->validate($value); + return 1 if ! defined $error; - Carp::confess($error); -} + Carp::confess($error); +} sub message { diff --git a/lib/Mouse/Object.pm b/lib/Mouse/Object.pm index 911954d..8aa22b5 100644 --- a/lib/Mouse/Object.pm +++ b/lib/Mouse/Object.pm @@ -71,7 +71,7 @@ sub dump { require 'Data/Dumper.pm'; # we don't want to create its namespace my $dd = Data::Dumper->new([$self]); - $dd->Maxdepth($maxdepth || 1); + $dd->Maxdepth(defined($maxdepth) ? $maxdepth : 1); return $dd->Dump(); } diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm index 1e8d028..b51f7bc 100644 --- a/lib/Mouse/Util.pm +++ b/lib/Mouse/Util.pm @@ -32,12 +32,12 @@ sub find_meta{ } sub does_role{ - my ($class_or_obj, $role) = @_; - - my $meta = Mouse::Meta::Module::class_of($class_or_obj); - - return 0 unless defined $meta; - return 1 if $meta->does_role($role); + my ($class_or_obj, $role) = @_; + + my $meta = Mouse::Meta::Module::class_of($class_or_obj); + + return 0 unless defined $meta; + return 1 if $meta->does_role($role); return 0; } @@ -87,44 +87,44 @@ BEGIN { } { # taken from Sub::Identify - sub get_code_info($) { - my ($coderef) = @_; - ref($coderef) or return; + sub get_code_info($) { + my ($coderef) = @_; + ref($coderef) or return; - my $cv = B::svref_2object($coderef); + my $cv = B::svref_2object($coderef); $cv->isa('B::CV') or return; - my $gv = $cv->GV; - $gv->isa('B::GV') or return; - - return ($gv->STASH->NAME, $gv->NAME); - } + my $gv = $cv->GV; + $gv->isa('B::GV') or return; + + return ($gv->STASH->NAME, $gv->NAME); + } } # taken from Mouse::Util (0.90) { my %cache; - sub resolve_metaclass_alias { - my ( $type, $metaclass_name, %options ) = @_; - - my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' ); + sub resolve_metaclass_alias { + my ( $type, $metaclass_name, %options ) = @_; + + my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' ); + + return $cache{$cache_key}{$metaclass_name} ||= do{ - return $cache{$cache_key}{$metaclass_name} ||= do{ - my $possible_full_name = join '::', 'Mouse::Meta', $type, 'Custom', ($options{trait} ? 'Trait' : ()), $metaclass_name ; - my $loaded_class = load_first_existing_class( - $possible_full_name, - $metaclass_name - ); - - $loaded_class->can('register_implementation') - ? $loaded_class->register_implementation + my $loaded_class = load_first_existing_class( + $possible_full_name, + $metaclass_name + ); + + $loaded_class->can('register_implementation') + ? $loaded_class->register_implementation : $loaded_class; - }; + }; } } @@ -265,15 +265,15 @@ sub apply_all_roles { # taken from Moose::Util 0.90 sub english_list { - return $_[0] if @_ == 1; - - my @items = sort @_; - - return "$items[0] and $items[1]" if @items == 2; - - my $tail = pop @items; - - return join q{, }, @items, "and $tail"; + return $_[0] if @_ == 1; + + my @items = sort @_; + + return "$items[0] and $items[1]" if @items == 2; + + my $tail = pop @items; + + return join q{, }, @items, "and $tail"; } sub not_supported{ diff --git a/t/100-meta-class.t b/t/100-meta-class.t index 264a81e..7a921bb 100644 --- a/t/100-meta-class.t +++ b/t/100-meta-class.t @@ -1,19 +1,38 @@ #!/usr/bin/env perl use strict; use warnings; -use Test::More tests => 15; - -do { +use Test::More tests => 22; +use Test::Exception; +{ package Class; use Mouse; + use Scalar::Util qw(blessed weaken); # import external functions has pawn => ( is => 'rw', predicate => 'has_pawn', ); + use constant MY_CONST => 42; + + sub stub; + sub stub_with_attr :method; + no Mouse; -}; +} +{ + package Child; + use Mouse; + use Carp qw(carp croak); # import extenral functions + + extends 'Class'; + + has bishop => ( + is => 'rw', + ); + + sub child_method{ } +} my $meta = Class->meta; isa_ok($meta, 'Mouse::Meta::Class'); @@ -23,37 +42,44 @@ is_deeply([$meta->superclasses], ['Mouse::Object'], "correctly inherting from Mo my $meta2 = Class->meta; is($meta, $meta2, "same metaclass instance"); -can_ok($meta, 'name', 'get_attribute_map', 'get_attribute_list'); +can_ok($meta, qw( + name meta + has_attribute get_attribute get_attribute_list get_all_attributes + has_method get_method get_method_list get_all_methods +)); ok($meta->has_attribute('pawn')); my $attr = $meta->get_attribute('pawn'); isa_ok($attr, 'Mouse::Meta::Attribute'); is($attr->name, 'pawn', 'got the correct attribute'); -my $map = $meta->get_attribute_map; -is_deeply($map, { pawn => $attr }, "attribute map"); - my $list = [$meta->get_attribute_list]; is_deeply($list, [ 'pawn' ], "attribute list"); ok(!$meta->has_attribute('nonexistent_attribute')); -eval " +ok($meta->has_method('pawn')); +lives_and{ + ok($meta->get_method('pawn')); + is($meta->get_method('pawn')->name, 'pawn'); + is($meta->get_method('pawn')->package_name, 'Class'); +}; + +is( join(' ', sort $meta->get_method_list), + join(' ', sort qw(meta pawn has_pawn MY_CONST stub stub_with_attr)) +); + +eval q{ package Class; use Mouse; no Mouse; -"; +}; my $meta3 = Class->meta; is($meta, $meta3, "same metaclass instance, even if use Mouse is performed again"); is($meta->name, 'Class', "name for the metaclass"); -do { - package Child; - use Mouse; - extends 'Class'; -}; my $child_meta = Child->meta; isa_ok($child_meta, 'Mouse::Meta::Class'); @@ -61,3 +87,12 @@ isa_ok($child_meta, 'Mouse::Meta::Class'); isnt($meta, $child_meta, "different metaclass instances for the two classes"); is_deeply([$child_meta->superclasses], ['Class'], "correct superclasses"); + + +ok($child_meta->has_attribute('bishop')); +ok($child_meta->has_method('child_method')); + + +is( join(' ', sort $child_meta->get_method_list), + join(' ', sort qw(meta bishop child_method)) +);