From: gfx Date: Mon, 21 Sep 2009 01:31:48 +0000 (+0900) Subject: Remove duplications and cleanup X-Git-Tag: 0.32~41 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=8536d351614f3b40a7fba3847438fb4803b2559b Remove duplications and cleanup --- diff --git a/lib/Mouse.pm b/lib/Mouse.pm index e03e12a..d006137 100644 --- a/lib/Mouse.pm +++ b/lib/Mouse.pm @@ -11,6 +11,7 @@ use Scalar::Util 'blessed'; use Mouse::Util; use Mouse::Meta::Attribute; +use Mouse::Meta::Module; # class_of() use Mouse::Meta::Class; use Mouse::Object; use Mouse::Util::TypeConstraints; @@ -239,10 +240,6 @@ sub is_class_loaded { return 0; } -sub class_of { - return Mouse::Meta::Class::class_of($_[0]); -} - 1; __END__ diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm index 6b75adf..abc8a25 100644 --- a/lib/Mouse/Meta/Class.pm +++ b/lib/Mouse/Meta/Class.pm @@ -10,55 +10,18 @@ use Carp 'confess'; use base qw(Mouse::Meta::Module); -do { - my %METACLASS_CACHE; - - # because Mouse doesn't introspect existing classes, we're forced to - # only pay attention to other Mouse classes - sub _metaclass_cache { - my $class = shift; - my $name = shift; - return $METACLASS_CACHE{$name}; - } - - sub initialize { - my($class, $package_name, @args) = @_; - - ($package_name && !ref($package_name)) - || confess("You must pass a package name and it cannot be blessed"); - - return $METACLASS_CACHE{$package_name} - ||= $class->_construct_class_instance(package => $package_name, @args); - } - - sub class_of{ - my($class_or_instance) = @_; - return undef unless defined $class_or_instance; - return $METACLASS_CACHE{ blessed($class_or_instance) || $class_or_instance }; - } - # Means of accessing all the metaclasses that have - # been initialized thus far - sub get_all_metaclasses { %METACLASS_CACHE } - sub get_all_metaclass_instances { values %METACLASS_CACHE } - sub get_all_metaclass_names { keys %METACLASS_CACHE } - sub get_metaclass_by_name { $METACLASS_CACHE{$_[0]} } - sub store_metaclass_by_name { $METACLASS_CACHE{$_[0]} = $_[1] } - sub weaken_metaclass { weaken($METACLASS_CACHE{$_[0]}) } - sub does_metaclass_exist { exists $METACLASS_CACHE{$_[0]} && defined $METACLASS_CACHE{$_[0]} } - sub remove_metaclass_by_name { $METACLASS_CACHE{$_[0]} = undef } -}; - -sub _construct_class_instance { +sub _new { my($class, %args) = @_; - $args{attributes} = {}; + $args{attributes} ||= {}; + $args{methods} ||= {}; + $args{roles} ||= []; + $args{superclasses} = do { no strict 'refs'; \@{ $args{package} . '::ISA' }; }; - $args{roles} ||= []; - $args{methods} ||= {}; bless \%args, $class; } @@ -135,15 +98,60 @@ sub get_all_attributes { return @attr; } -sub get_attribute_map { $_[0]->{attributes} } -sub has_attribute { exists $_[0]->{attributes}->{$_[1]} } -sub get_attribute { $_[0]->{attributes}->{$_[1]} } -sub get_attribute_list { +sub linearized_isa { @{ get_linear_isa($_[0]->name) } } + +sub new_object { my $self = shift; - keys %{$self->get_attribute_map}; -} + my $args = (@_ == 1) ? $_[0] : { @_ }; -sub linearized_isa { @{ get_linear_isa($_[0]->name) } } + foreach my $attribute ($self->meta->get_all_attributes) { + my $from = $attribute->init_arg; + my $key = $attribute->name; + + if (defined($from) && exists($args->{$from})) { + $args->{$from} = $attribute->coerce_constraint($args->{$from}) + if $attribute->should_coerce; + $attribute->verify_against_type_constraint($args->{$from}); + + $instance->{$key} = $args->{$from}; + + weaken($instance->{$key}) + if $attribute->is_weak_ref; + + if ($attribute->has_trigger) { + $attribute->trigger->($instance, $args->{$from}); + } + } + else { + if ($attribute->has_default || $attribute->has_builder) { + unless ($attribute->is_lazy) { + my $default = $attribute->default; + my $builder = $attribute->builder; + my $value = $attribute->has_builder + ? $instance->$builder + : ref($default) eq 'CODE' + ? $default->($instance) + : $default; + + $value = $attribute->coerce_constraint($value) + if $attribute->should_coerce; + $attribute->verify_against_type_constraint($value); + + $instance->{$key} = $value; + + weaken($instance->{$key}) + if $attribute->is_weak_ref; + } + } + else { + if ($attribute->is_required) { + confess "Attribute (".$attribute->name.") is required"; + } + } + } + } + return $instance; +} sub clone_object { my $class = shift; @@ -276,7 +284,7 @@ sub does_role { || confess "You must supply a role name to look for"; for my $class ($self->linearized_isa) { - my $meta = class_of($class); + my $meta = Mouse::class_of($class); next unless $meta && $meta->can('roles'); for my $role (@{ $meta->roles }) { diff --git a/lib/Mouse/Meta/Module.pm b/lib/Mouse/Meta/Module.pm index f24c76e..8dedd7e 100755 --- a/lib/Mouse/Meta/Module.pm +++ b/lib/Mouse/Meta/Module.pm @@ -3,12 +3,53 @@ use strict; use warnings; use Mouse::Util qw/get_code_info/; -use Carp 'confess'; +use Scalar::Util qw/blessed/; +use Carp (); + +{ + my %METACLASS_CACHE; + + # because Mouse doesn't introspect existing classes, we're forced to + # only pay attention to other Mouse classes + sub _metaclass_cache { + my($class, $name) = @_; + return $METACLASS_CACHE{$name}; + } + + sub initialize { + my($class, $package_name, @args) = @_; + + ($package_name && !ref($package_name)) + || confess("You must pass a package name and it cannot be blessed"); + + return $METACLASS_CACHE{$package_name} + ||= $class->_new(package => $package_name, @args); + } + + sub Mouse::class_of{ + my($class_or_instance) = @_; + return undef unless defined $class_or_instance; + return $METACLASS_CACHE{ blessed($class_or_instance) || $class_or_instance }; + } + + # Means of accessing all the metaclasses that have + # been initialized thus far + sub get_all_metaclasses { %METACLASS_CACHE } + sub get_all_metaclass_instances { values %METACLASS_CACHE } + sub get_all_metaclass_names { keys %METACLASS_CACHE } + sub get_metaclass_by_name { $METACLASS_CACHE{$_[0]} } + sub store_metaclass_by_name { $METACLASS_CACHE{$_[0]} = $_[1] } + sub weaken_metaclass { weaken($METACLASS_CACHE{$_[0]}) } + sub does_metaclass_exist { defined $METACLASS_CACHE{$_[0]} } + sub remove_metaclass_by_name { delete $METACLASS_CACHE{$_[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'} } sub identifier { @@ -20,6 +61,12 @@ sub identifier { ); } +# add_attribute is an abstract method + +sub get_attribute_map { $_[0]->{attributes} } +sub has_attribute { exists $_[0]->{attributes}->{$_[1]} } +sub get_attribute { $_[0]->{attributes}->{$_[1]} } +sub get_attribute_list{ keys %{$_[0]->{attributes}} } sub namespace{ my $name = $_[0]->{package}; @@ -63,7 +110,9 @@ sub has_method { return $code && $self->_code_is_mine($code); } - +sub get_method{ + Carp::croak("get_method() is not yet implemented"); +} sub get_method_list { my($self) = @_; @@ -71,14 +120,19 @@ sub get_method_list { return grep { $self->has_method($_) } keys %{ $self->namespace }; } -sub get_attribute_map { $_[0]->{attributes} } -sub has_attribute { exists $_[0]->{attributes}->{$_[1]} } -sub get_attribute { $_[0]->{attributes}->{$_[1]} } -sub get_attribute_list { - my $self = shift; - keys %{$self->get_attribute_map}; -} +sub throw_error{ + my($class, $message, %args) = @_; + + local $Carp::CarpLevel = $Carp::CarpLevel + ($args{depth} || 1); + 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); + } + else{ + Carp::confess($message); + } +} 1; diff --git a/lib/Mouse/Meta/Role.pm b/lib/Mouse/Meta/Role.pm index 35bc9ea..db9a867 100644 --- a/lib/Mouse/Meta/Role.pm +++ b/lib/Mouse/Meta/Role.pm @@ -5,28 +5,6 @@ use Carp 'confess'; use base qw(Mouse::Meta::Module); -do { - my %METACLASS_CACHE; - - # because Mouse doesn't introspect existing classes, we're forced to - # only pay attention to other Mouse classes - sub _metaclass_cache { - my $class = shift; - my $name = shift; - return $METACLASS_CACHE{$name}; - } - - sub initialize { - my($class, $package_name, @args) = @_; - - ($package_name && !ref($package_name)) - || confess("You must pass a package name and it cannot be blessed"); - - return $METACLASS_CACHE{$package_name} - ||= $class->_new(package => $package_name, @args); - } -}; - sub _new { my $class = shift; my %args = @_; @@ -55,10 +33,6 @@ sub add_attribute { $self->{attributes}->{$name} = $spec; } -sub has_attribute { exists $_[0]->{attributes}->{$_[1]} } -sub get_attribute_list { keys %{ $_[0]->{attributes} } } -sub get_attribute { $_[0]->{attributes}->{$_[1]} } - sub _check_required_methods{ my($role, $class, $args, @other_roles) = @_; diff --git a/lib/Mouse/Object.pm b/lib/Mouse/Object.pm index 47626d3..a641129 100644 --- a/lib/Mouse/Object.pm +++ b/lib/Mouse/Object.pm @@ -2,65 +2,17 @@ package Mouse::Object; use strict; use warnings; -use Scalar::Util 'weaken'; use Carp 'confess'; sub new { my $class = shift; - my $args = $class->BUILDARGS(@_); + confess('Cannot call new() on an instance') if ref $class; - my $instance = bless {}, $class; - - for my $attribute ($class->meta->get_all_attributes) { - my $from = $attribute->init_arg; - my $key = $attribute->name; - - if (defined($from) && exists($args->{$from})) { - $args->{$from} = $attribute->coerce_constraint($args->{$from}) - if $attribute->should_coerce; - $attribute->verify_against_type_constraint($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}); - } - } - else { - if ($attribute->has_default || $attribute->has_builder) { - unless ($attribute->is_lazy) { - my $default = $attribute->default; - my $builder = $attribute->builder; - my $value = $attribute->has_builder - ? $instance->$builder - : ref($default) eq 'CODE' - ? $default->($instance) - : $default; - - $value = $attribute->coerce_constraint($value) - if $attribute->should_coerce; - $attribute->verify_against_type_constraint($value); - - $instance->{$key} = $value; - - weaken($instance->{$key}) - if ref($instance->{$key}) && $attribute->is_weak_ref; - } - } - else { - if ($attribute->is_required) { - confess "Attribute (".$attribute->name.") is required"; - } - } - } - } + my $args = $class->BUILDARGS(@_); + my $instance = Mouse::Meta::Class->initialize($class)->new_object($params); $instance->BUILDALL($args); - return $instance; } @@ -101,34 +53,26 @@ sub DEMOLISHALL { # short circuit return unless $self->can('DEMOLISH'); - no strict 'refs'; - - my @isa; - if ( my $meta = Mouse::Meta::Class::class_of($self) ) { - @isa = $meta->linearized_isa; - } else { - # We cannot count on being able to retrieve a previously made - # metaclass, _or_ being able to make a new one during global - # destruction. However, we should still be able to use mro at - # that time (at least tests suggest so ;) - my $class_name = ref $self; - @isa = @{ Mouse::Util::get_linear_isa($class_name) } - } + # We cannot count on being able to retrieve a previously made + # metaclass, _or_ being able to make a new one during global + # destruction. However, we should still be able to use mro at + # that time (at least tests suggest so ;) - foreach my $class (@isa) { - no strict 'refs'; - my $demolish = *{"${class}::DEMOLISH"}{CODE}; - $self->$demolish + foreach my $class (@{ Mouse::Util::get_linear_isa(ref $self) }) { + my $demolish = do{ no strict 'refs'; *{"${class}::DEMOLISH"}{CODE} }; + $self->$demolish() if defined $demolish; } return; } sub dump { - my $self = shift; - require Data::Dumper; - local $Data::Dumper::Maxdepth = shift if @_; - Data::Dumper::Dumper($self); + my($self, $maxdepth) = @_; + + require 'Data/Dumper.pm'; # we don't want to create its namespace + my $dd = Data::Dumper->new([$self]); + $dd->Maxdepth($maxdepth || 1); + return $dd->Dump(); }