From: Stevan Little Date: Thu, 20 Apr 2006 19:40:23 +0000 (+0000) Subject: coolio X-Git-Tag: 0_05~15 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d500266fbd574bc8202df459573f24afc18041c6;p=gitmo%2FMoose.git coolio --- diff --git a/Build.PL b/Build.PL index 5679b16..230f48b 100644 --- a/Build.PL +++ b/Build.PL @@ -8,7 +8,7 @@ my $build = Module::Build->new( requires => { 'Scalar::Util' => '1.18', 'Carp' => '0', - 'Class::MOP' => '0.22', + 'Class::MOP' => '0.25', 'Sub::Name' => '0.02', 'UNIVERSAL::require' => '0', 'Sub::Exporter' => '0', # update this when rjbs releases diff --git a/Changes b/Changes index f300916..278eadc 100644 --- a/Changes +++ b/Changes @@ -22,6 +22,14 @@ Revision history for Perl extension Moose - keywords are now exported with Sub::Exporter thanks chansen for this commit + * Moose::Meta::Class + - due to changes in Class::MOP, we had to change + construct_instance (for the better) + + * Moose::Meta::Attribute + - due to changes in Class::MOP, we had to add the + initialize_instance_slot method (it's a good thing) + 0.04 Sun. April 16th, 2006 * Moose::Role - Roles can now consume other roles diff --git a/lib/Moose.pm b/lib/Moose.pm index ac35d37..6d18e15 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -42,8 +42,6 @@ use Moose::Util::TypeConstraints; $meta = $class->meta(); (blessed($meta) && $meta->isa('Moose::Meta::Class')) || confess "Whoops, not møøsey enough"; - ($meta->attribute_metaclass->isa('Moose::Meta::Attribute')) - || confess "Attribute metaclass must be a subclass of Moose::Meta::Attribute"; } else { $meta = Moose::Meta::Class->initialize($class); @@ -82,8 +80,6 @@ use Moose::Util::TypeConstraints; my ($name, %options) = @_; if ($options{metaclass}) { _load_all_classes($options{metaclass}); - ($options{metaclass}->isa('Moose::Meta::Attribute')) - || confess "Custom attribute metaclass must be a subclass of Moose::Meta::Attribute"; $meta->add_attribute($options{metaclass}->new($name, %options)); } else { diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm index bcb588c..7f1d925 100644 --- a/lib/Moose/Meta/Attribute.pm +++ b/lib/Moose/Meta/Attribute.pm @@ -110,6 +110,41 @@ sub new { $class->SUPER::new($name, %options); } +sub initialize_instance_slot { + my ($self, $class, $instance, $params) = @_; + my $init_arg = $self->init_arg(); + # try to fetch the init arg from the %params ... + my $val; + if (exists $params->{$init_arg}) { + $val = $params->{$init_arg}; + } + else { + # skip it if it's lazy + return if $self->is_lazy; + # and die if it's required and doesn't have a default value + confess "Attribute (" . $self->name . ") is required" + if $self->is_required && !$self->has_default; + } + # if nothing was in the %params, we can use the + # attribute's default value (if it has one) + if (!defined $val && $self->has_default) { + $val = $self->default($instance); + } + if (defined $val) { + if ($self->has_type_constraint) { + if ($self->should_coerce && $self->type_constraint->has_coercion) { + $val = $self->type_constraint->coercion->coerce($val); + } + (defined($self->type_constraint->check($val))) + || confess "Attribute (" . $self->name . ") does not pass the type contraint with '$val'"; + } + } + $instance->{$self->name} = $val; + if (defined $val && $self->is_weak_ref) { + weaken($instance->{$self->name}); + } +} + sub generate_accessor_method { my ($self, $attr_name) = @_; my $value_name = $self->should_coerce ? '$val' : '$_[1]'; @@ -220,6 +255,8 @@ will behave just as L does. =item B +=item B + =item B =item B diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm index 5c7647f..8a3cf27 100644 --- a/lib/Moose/Meta/Class.pm +++ b/lib/Moose/Meta/Class.pm @@ -47,7 +47,7 @@ sub new_object { my ($class, %params) = @_; my $self = $class->SUPER::new_object(%params); foreach my $attr ($class->compute_all_applicable_attributes()) { - next unless $params{$attr->name} && $attr->has_trigger; + next unless $params{$attr->name} && $attr->can('has_trigger') && $attr->has_trigger; $attr->trigger->($self, $params{$attr->name}); } return $self; @@ -57,37 +57,7 @@ sub construct_instance { my ($class, %params) = @_; my $instance = $params{'__INSTANCE__'} || {}; foreach my $attr ($class->compute_all_applicable_attributes()) { - my $init_arg = $attr->init_arg(); - # try to fetch the init arg from the %params ... - my $val; - if (exists $params{$init_arg}) { - $val = $params{$init_arg}; - } - else { - # skip it if it's lazy - next if $attr->is_lazy; - # and die if it's required and doesn't have a default value - confess "Attribute (" . $attr->name . ") is required" - if $attr->is_required && !$attr->has_default; - } - # if nothing was in the %params, we can use the - # attribute's default value (if it has one) - if (!defined $val && $attr->has_default) { - $val = $attr->default($instance); - } - if (defined $val) { - if ($attr->has_type_constraint) { - if ($attr->should_coerce && $attr->type_constraint->has_coercion) { - $val = $attr->type_constraint->coercion->coerce($val); - } - (defined($attr->type_constraint->check($val))) - || confess "Attribute (" . $attr->name . ") does not pass the type contraint with '$val'"; - } - } - $instance->{$attr->name} = $val; - if (defined $val && $attr->is_weak_ref) { - weaken($instance->{$attr->name}); - } + $attr->initialize_instance_slot($class, $instance, \%params) } return $instance; } diff --git a/t/036_custom_attribute_metaclass.t b/t/036_custom_attribute_metaclass.t index eab082f..395741b 100644 --- a/t/036_custom_attribute_metaclass.t +++ b/t/036_custom_attribute_metaclass.t @@ -14,13 +14,16 @@ BEGIN { package Foo::Meta::Attribute; use strict; use warnings; + use Moose; - use base 'Moose::Meta::Attribute'; + extends 'Moose::Meta::Attribute'; - sub new { - my $class = shift; - $class->SUPER::new(@_, (is => 'rw', isa => 'Foo')); - } + around 'new' => sub { + my $next = shift; + my $self = shift; + my $name = shift; + $next->($self, $name, (is => 'rw', isa => 'Foo'), @_); + }; package Foo; use strict; @@ -52,16 +55,17 @@ is($foo_attr_type_constraint->parent->name, 'Object', '... got the right type co package Bar::Meta::Attribute; use strict; use warnings; + use Moose; - use base 'Class::MOP::Attribute'; + extends 'Class::MOP::Attribute'; package Bar; use strict; use warnings; use Moose; - ::dies_ok { + ::lives_ok { has 'bar' => (metaclass => 'Bar::Meta::Attribute'); - } '... the attribute metaclass must be a subclass of Moose::Meta::Attribute'; + } '... the attribute metaclass need not be a Moose::Meta::Attribute as long as it behaves'; } diff --git a/t/060_moose_for_meta.t b/t/060_moose_for_meta.t new file mode 100644 index 0000000..de4c1d7 --- /dev/null +++ b/t/060_moose_for_meta.t @@ -0,0 +1,64 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 16; +use Test::Exception; + +BEGIN { + use_ok('Moose'); +} + +{ + package My::Meta::Class; + use strict; + use warnings; + use Moose; + + extends 'Moose::Meta::Class'; +} + +my $anon = My::Meta::Class->create_anon_class(); +isa_ok($anon, 'My::Meta::Class'); +isa_ok($anon, 'Moose::Meta::Class'); +isa_ok($anon, 'Class::MOP::Class'); + +{ + package My::Meta::Attribute::DefaultReadOnly; + use strict; + use warnings; + use Moose; + + extends 'Moose::Meta::Attribute'; + + around 'new' => sub { + my $next = shift; + my $self = shift; + my $name = shift; + $next->($self, $name, (is => 'ro'), @_); + }; +} + +{ + my $attr = My::Meta::Attribute::DefaultReadOnly->new('foo'); + isa_ok($attr, 'My::Meta::Attribute::DefaultReadOnly'); + isa_ok($attr, 'Moose::Meta::Attribute'); + isa_ok($attr, 'Class::MOP::Attribute'); + + ok($attr->has_reader, '... the attribute has a reader (as expected)'); + ok(!$attr->has_writer, '... the attribute does not have a writer (as expected)'); + ok(!$attr->has_accessor, '... the attribute does not have an accessor (as expected)'); +} + +{ + my $attr = My::Meta::Attribute::DefaultReadOnly->new('foo', (is => 'rw')); + isa_ok($attr, 'My::Meta::Attribute::DefaultReadOnly'); + isa_ok($attr, 'Moose::Meta::Attribute'); + isa_ok($attr, 'Class::MOP::Attribute'); + + ok(!$attr->has_reader, '... the attribute does not have a reader (as expected)'); + ok(!$attr->has_writer, '... the attribute does not have a writer (as expected)'); + ok($attr->has_accessor, '... the attribute does have an accessor (as expected)'); +} +