X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMouse%2FObject.pm;h=1511d2836f75650c749b790699b57460919c5823;hb=84e9b28560b15545a21b389885b0c9514fa93165;hp=2138adf8df5119e3a71b0207eb8bcc6453ce71e4;hpb=28d269491e4b8dad61231390965529c3993a2ba5;p=gitmo%2FMouse.git diff --git a/lib/Mouse/Object.pm b/lib/Mouse/Object.pm index 2138adf..1511d28 100644 --- a/lib/Mouse/Object.pm +++ b/lib/Mouse/Object.pm @@ -2,24 +2,15 @@ package Mouse::Object; use strict; use warnings; -use MRO::Compat; +use MRO::Compat; use Scalar::Util qw/blessed weaken/; use Carp 'confess'; sub new { my $class = shift; - my %args; - if (scalar @_ == 1) { - if (defined $_[0]) { - (ref($_[0]) eq 'HASH') - || confess "Single parameters to new() must be a HASH ref"; - %args = %{$_[0]}; - } - } - else { - %args = @_; - } + + my $args = $class->BUILDARGS(@_); my $instance = bless {}, $class; @@ -28,7 +19,39 @@ sub new { my $key = $attribute->name; my $default; - if (!exists($args{$from})) { + if (defined($from) && exists($args->{$from})) { + if ($attribute->has_trigger && $attribute->trigger->{before}) { + $attribute->trigger->{before}->($instance, $args->{$from}, $attribute); + } + + if ($attribute->has_trigger && $attribute->trigger->{around}) { + $attribute->trigger->{around}->(sub { + $args->{$from} = $_[1]; + + $attribute->verify_type_constraint($args->{$from}) + if $attribute->has_type_constraint; + + $instance->{$key} = $args->{$from}; + + weaken($instance->{$key}) + if ref($instance->{$key}) && $attribute->is_weak_ref; + }, $instance, $args->{$from}, $attribute); + } + else { + $attribute->verify_type_constraint($args->{$from}) + if $attribute->has_type_constraint; + + $instance->{$key} = $args->{$from}; + + weaken($instance->{$key}) + if ref($instance->{$key}) && $attribute->is_weak_ref; + } + + if ($attribute->has_trigger && $attribute->trigger->{after}) { + $attribute->trigger->{after}->($instance, $args->{$from}, $attribute); + } + } + else { if ($attribute->has_default || $attribute->has_builder) { unless ($attribute->is_lazy) { my $default = $attribute->default; @@ -54,25 +77,28 @@ sub new { } } } + } - if (exists($args{$from})) { - $attribute->verify_type_constraint($args{$from}) - if $attribute->has_type_constraint; + $instance->BUILDALL($args); - $instance->{$key} = $args{$from}; + return $instance; +} - weaken($instance->{$key}) - if ref($instance->{$key}) && $attribute->is_weak_ref; +sub BUILDARGS { + my $class = shift; - if ($attribute->has_trigger) { - $attribute->trigger->($instance, $args{$from}, $attribute); - } + if (scalar @_ == 1) { + if (defined $_[0]) { + (ref($_[0]) eq 'HASH') + || confess "Single parameters to new() must be a HASH ref"; + return {%{$_[0]}}; + } else { + return {}; } } - - $instance->BUILDALL(\%args); - - return $instance; + else { + return {@_}; + } } sub DESTROY { shift->DEMOLISHALL } @@ -83,9 +109,9 @@ sub BUILDALL { # short circuit return unless $self->can('BUILD'); - no strict 'refs'; - for my $class (reverse $self->meta->linearized_isa) { + no strict 'refs'; + no warnings 'once'; my $code = *{ $class . '::BUILD' }{CODE} or next; $code->($self, @_); @@ -131,6 +157,11 @@ end of L. You may put any business logic initialization in BUILD methods. You don't need to redispatch or return any specific value. +=head2 BUILDARGS + +Lets you override the arguments that C takes. Return a hashref of +parameters. + =head2 DEMOLISHALL Calls L on each class in the class hierarchy. This is called at