-# auto-generated shipit config file.\r
-steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist\r
-\r
-git.tagpattern = %v\r
-git.push_to = origin\r
-\r
-CheckChangeLog.files = Changes\r
+# auto-generated shipit config file.
+steps = FindVersion, ChangeVersion, CheckChangeLog, DistTest, Commit, Tag, MakeDist
+
+git.tagpattern = %v
+git.push_to = origin
+
+CheckChangeLog.files = Changes
sub method_metaclass(){ 'Mouse::Meta::Method' } # required for get_method()
-sub _new {
+sub _construct_meta {
my($class, %args) = @_;
$args{attributes} ||= {};
#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{
@{ $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 {
-package Mouse::Meta::Method;\r
-use strict;\r
-use warnings;\r
-\r
-use overload\r
- '&{}' => 'body',\r
- fallback => 1,\r
-;\r
-\r
-sub new{\r
- my($class, %args) = @_;\r
-\r
- return bless \%args, $class;\r
-}\r
-\r
-sub body { $_[0]->{body} }\r
-sub name { $_[0]->{name} }\r
-sub package{ $_[0]->{name} }\r
-\r
-\r
-1;\r
-\r
-__END__\r
+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__
foreach my $handle_name (keys %handles) {
my $method_to_call = $handles{$handle_name};
- my $code = sub {\r
- my $instance = shift;\r
- my $proxy = $instance->$reader();\r
-\r
- my $error = !defined($proxy) ? ' is not defined'\r
- : ref($proxy) && !blessed($proxy) ? qq{ is not an object (got '$proxy')}\r
- : undef;\r
+ 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(\r
- "Cannot delegate $handle_name to $method_to_call because "\r
- . "the value of "\r
- . $attribute->name\r
+ $instance->meta->throw_error(
+ "Cannot delegate $handle_name to $method_to_call because "
+ . "the value of "
+ . $attribute->name
. $error
- );\r
- }\r
- $proxy->$method_to_call(@_);\r
+ );
+ }
+ $proxy->$method_to_call(@_);
};
$class->add_method($handle_name => $code);
}
sub initialize {
my($class, $package_name, @args) = @_;
- ($package_name && !ref($package_name))\r
- || $class->throw_error("You must pass a package name and it cannot be blessed");\r
+ ($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{
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'} }
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';
*{ $pkg . '::' . $name } = $code;
}
-sub _code_is_mine { # taken from Class::MOP::Class\r
- my ( $self, $code ) = @_;\r
-\r
- my ( $code_package, $code_name ) = get_code_info($code);\r
-\r
- return $code_package && $code_package eq $self->name\r
- || ( $code_package eq 'constant' && $code_name eq '__ANON__' );\r
+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);
return undef;
}
-sub get_method_list {\r
+sub get_method_list {
my($self) = @_;
-\r
- return grep { $self->has_method($_) } keys %{ $self->namespace };\r
+
+ return grep { $self->has_method($_) } keys %{ $self->namespace };
}
{
# anonymous but immortal
if(!$mortal){
- # something like Super::Class|Super::Class::2=Role|Role::1\r
- $cache_key = join '=' => (\r
- join('|', @{$options{superclasses} || []}),\r
- join('|', sort @{$options{roles} || []}),\r
+ # 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};
}
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\r
+ 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);
sub method_metaclass(){ 'Mouse::Meta::Role::Method' } # required for get_method()
-sub _new {
+sub _construct_meta {
my $class = shift;
my %args = @_;
# 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{
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' "\r
+ $class->throw_error("We have encountered an attribute conflict with '$attr_name' "
. "during composition. This is fatal error and cannot be disambiguated.")
}
else{
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 "\r
- . "composition (Two 'override' methods of the same name encountered). "\r
+ $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{
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' "\r
+ $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)");
}
$self->{override_method_modifiers}->{$method_name} = $method;
}
-sub has_override_method_modifier {\r
- my ($self, $method_name) = @_;\r
- return exists $self->{override_method_modifiers}->{$method_name};\r
-}\r
-\r
-sub get_override_method_modifier {\r
- my ($self, $method_name) = @_;\r
- return $self->{override_method_modifiers}->{$method_name};\r
+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 {
-package Mouse::Meta::Role::Method;\r
-use strict;\r
-use warnings;\r
-\r
-use base qw(Mouse::Meta::Method);\r
-\r
-1;\r
-\r
-__END__\r
-\r
+package Mouse::Meta::Role::Method;
+use strict;
+use warnings;
+
+use base qw(Mouse::Meta::Method);
+
+1;
+
+__END__
+
}
sub validate {
- my ($self, $value) = @_;\r
- if ($self->{_compiled_type_constraint}->($value)) {\r
- return undef;\r
- }\r
- else {\r
- $self->get_message($value);\r
- }\r
+ my ($self, $value) = @_;
+ if ($self->{_compiled_type_constraint}->($value)) {
+ return undef;
+ }
+ else {
+ $self->get_message($value);
+ }
}
-sub assert_valid {\r
- my ($self, $value) = @_;\r
-\r
- my $error = $self->validate($value);\r
- return 1 if ! defined $error;\r
+sub assert_valid {
+ my ($self, $value) = @_;
+
+ my $error = $self->validate($value);
+ return 1 if ! defined $error;
- Carp::confess($error);\r
-}\r
+ Carp::confess($error);
+}
sub message {
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();
}
}
sub does_role{
- my ($class_or_obj, $role) = @_;\r
-\r
- my $meta = Mouse::Meta::Module::class_of($class_or_obj);\r
-\r
- return 0 unless defined $meta;\r
- return 1 if $meta->does_role($role);\r
+ 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;
}
}
{ # taken from Sub::Identify
- sub get_code_info($) {\r
- my ($coderef) = @_;\r
- ref($coderef) or return;\r
+ sub get_code_info($) {
+ my ($coderef) = @_;
+ ref($coderef) or return;
- my $cv = B::svref_2object($coderef);\r
+ my $cv = B::svref_2object($coderef);
$cv->isa('B::CV') or return;
- my $gv = $cv->GV;\r
- $gv->isa('B::GV') or return;\r
-\r
- return ($gv->STASH->NAME, $gv->NAME);\r
- }\r
+ 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 {\r
- my ( $type, $metaclass_name, %options ) = @_;\r
-\r
- my $cache_key = $type . q{ } . ( $options{trait} ? '-Trait' : '' );\r
+ 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{\r
-\r
my $possible_full_name = join '::',
'Mouse::Meta', $type, 'Custom', ($options{trait} ? 'Trait' : ()), $metaclass_name
;
- my $loaded_class = load_first_existing_class(\r
- $possible_full_name,\r
- $metaclass_name\r
- );\r
-\r
- $loaded_class->can('register_implementation')\r
- ? $loaded_class->register_implementation\r
+ my $loaded_class = load_first_existing_class(
+ $possible_full_name,
+ $metaclass_name
+ );
+
+ $loaded_class->can('register_implementation')
+ ? $loaded_class->register_implementation
: $loaded_class;
- };\r
+ };
}
}
# taken from Moose::Util 0.90
sub english_list {
- return $_[0] if @_ == 1;\r
-
- my @items = sort @_;\r
-\r
- return "$items[0] and $items[1]" if @items == 2;\r
-\r
- my $tail = pop @items;\r
-\r
- return join q{, }, @items, "and $tail";\r
+ 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{
#!/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');
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');
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))
+);
projects / gitmo/Mouse.git / commitdiff