X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=lib%2FMouse%2FPurePerl.pm;h=ecc61e103a466c19e91c9f5724bc731e4343f9d8;hp=f5e3599f5a4cd33fa069de391455d45cfed2efad;hb=6423ed47a3392af0da9cd37ac8519583e51feb27;hpb=c5f6ad05f942b8a1aab0c85e55338a6e498a2bf0 diff --git a/lib/Mouse/PurePerl.pm b/lib/Mouse/PurePerl.pm index f5e3599..ecc61e1 100644 --- a/lib/Mouse/PurePerl.pm +++ b/lib/Mouse/PurePerl.pm @@ -203,6 +203,7 @@ sub add_method { package Mouse::Meta::Class; + sub is_anon_class{ return exists $_[0]->{anon_serial_id}; } @@ -213,10 +214,65 @@ sub linearized_isa { @{ get_linear_isa($_[0]->{package}) } } sub get_all_attributes { my($self) = @_; - my %attrs = map { %{ $self->initialize($_)->_attribute_map } } reverse $self->linearized_isa; + my %attrs = map { %{ $self->initialize($_)->{attributes} } } reverse $self->linearized_isa; return values %attrs; } +sub _initialize_object{ + my($self, $object, $args, $ignore_triggers) = @_; + + my @triggers_queue; + + foreach my $attribute ($self->get_all_attributes) { + my $init_arg = $attribute->init_arg; + my $slot = $attribute->name; + + if (defined($init_arg) && exists($args->{$init_arg})) { + $object->{$slot} = $attribute->_coerce_and_verify($args->{$init_arg}, $object); + + weaken($object->{$slot}) + if ref($object->{$slot}) && $attribute->is_weak_ref; + + if ($attribute->has_trigger) { + push @triggers_queue, [ $attribute->trigger, $object->{$slot} ]; + } + } + else { # no init arg + if ($attribute->has_default || $attribute->has_builder) { + if (!$attribute->is_lazy) { + my $default = $attribute->default; + my $builder = $attribute->builder; + my $value = $builder ? $object->$builder() + : ref($default) eq 'CODE' ? $object->$default() + : $default; + + $object->{$slot} = $attribute->_coerce_and_verify($value, $object); + + weaken($object->{$slot}) + if ref($object->{$slot}) && $attribute->is_weak_ref; + } + } + elsif($attribute->is_required) { + $self->throw_error("Attribute (".$attribute->name.") is required"); + } + } + } + + if(!$ignore_triggers){ + foreach my $trigger_and_value(@triggers_queue){ + my($trigger, $value) = @{$trigger_and_value}; + $trigger->($object, $value); + } + } + + if($self->is_anon_class){ + $object->{__METACLASS__} = $self; + } + + return; +} + + package Mouse::Meta::Role; @@ -337,8 +393,24 @@ sub compile_type_constraint{ return; } +package + Mouse::Object; +sub BUILDARGS { + my $class = shift; + + if (scalar @_ == 1) { + (ref($_[0]) eq 'HASH') + || $class->meta->throw_error("Single parameters to new() must be a HASH ref"); + + return {%{$_[0]}}; + } + else { + return {@_}; + } +} + 1; __END__