From: Stevan Little Date: Thu, 26 Oct 2006 21:33:58 +0000 (+0000) Subject: added new constructor method metaclass X-Git-Tag: 0_36~2^2~2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=817c7cd51b8e7a9509c43428f47e231d0e21ff43;p=gitmo%2FClass-MOP.git added new constructor method metaclass --- diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 66db0e2..adbccfa 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -373,6 +373,56 @@ Class::MOP::Method::Wrapped->meta->add_attribute( ); ## -------------------------------------------------------- +## Class::MOP::Method::Accessor + +Class::MOP::Method::Accessor->meta->add_attribute( + Class::MOP::Attribute->new('attribute' => ( + reader => { + 'associated_attribute' => \&Class::MOP::Method::Accessor::associated_attribute + }, + )) +); + +Class::MOP::Method::Accessor->meta->add_attribute( + Class::MOP::Attribute->new('accessor_type' => ( + reader => { 'accessor_type' => \&Class::MOP::Method::Accessor::accessor_type }, + )) +); + +Class::MOP::Method::Accessor->meta->add_attribute( + Class::MOP::Attribute->new('is_inline' => ( + reader => { 'is_inline' => \&Class::MOP::Method::Accessor::is_inline }, + )) +); + +## -------------------------------------------------------- +## Class::MOP::Method::Constructor + +Class::MOP::Method::Constructor->meta->add_attribute( + Class::MOP::Attribute->new('options' => ( + reader => { + 'options' => \&Class::MOP::Method::Constructor::options + }, + )) +); + +Class::MOP::Method::Constructor->meta->add_attribute( + Class::MOP::Attribute->new('meta_instance' => ( + reader => { + 'meta_instance' => \&Class::MOP::Method::Constructor::meta_instance + }, + )) +); + +Class::MOP::Method::Constructor->meta->add_attribute( + Class::MOP::Attribute->new('attributes' => ( + reader => { + 'attributes' => \&Class::MOP::Method::Constructor::attributes + }, + )) +); + +## -------------------------------------------------------- ## Class::MOP::Instance # NOTE: @@ -412,7 +462,8 @@ $_->meta->make_immutable( Class::MOP::Object Class::MOP::Method::Accessor - Class::MOP::Method::Wrapped + Class::MOP::Method::Constructor + Class::MOP::Method::Wrapped /; 1; diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index c8ab6c0..376b9b1 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -211,7 +211,7 @@ sub process_accessors { eval { $method = $self->accessor_metaclass->new( attribute => $self, - as_inline => $inline_me, + is_inline => $inline_me, accessor_type => $type, ); }; diff --git a/lib/Class/MOP/Class/Immutable.pm b/lib/Class/MOP/Class/Immutable.pm index 942708c..2b020b4 100644 --- a/lib/Class/MOP/Class/Immutable.pm +++ b/lib/Class/MOP/Class/Immutable.pm @@ -4,8 +4,10 @@ package Class::MOP::Class::Immutable; use strict; use warnings; +use Class::MOP::Method::Constructor; + use Carp 'confess'; -use Scalar::Util 'blessed', 'looks_like_number'; +use Scalar::Util 'blessed'; our $VERSION = '0.03'; our $AUTHORITY = 'cpan:STEVAN'; @@ -88,19 +90,21 @@ sub make_metaclass_immutable { if ($options{inline_accessors}) { foreach my $attr_name ($metaclass->get_attribute_list) { - my $attr = $metaclass->get_attribute($attr_name); - $attr->install_accessors(1); # inline the accessors + # inline the accessors + $metaclass->get_attribute($attr_name) + ->install_accessors(1); } } if ($options{inline_constructor}) { + my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor'; $metaclass->add_method( $options{constructor_name}, - $class->_generate_inline_constructor( - \%options, - $meta_instance, - $metaclass->{'___compute_all_applicable_attributes'} - ) + $constructor_class->new( + options => \%options, + meta_instance => $meta_instance, + attributes => $metaclass->{'___compute_all_applicable_attributes'} + ) ); } @@ -110,58 +114,6 @@ sub make_metaclass_immutable { bless $metaclass => $class; } -sub _generate_inline_constructor { - my ($class, $options, $meta_instance, $attrs) = @_; - # TODO: - # the %options should also include a both - # a call 'initializer' and call 'SUPER::' - # options, which should cover approx 90% - # of the possible use cases (even if it - # requires some adaption on the part of - # the author, after all, nothing is free) - my $source = 'sub {'; - $source .= "\n" . 'my ($class, %params) = @_;'; - $source .= "\n" . 'my $instance = ' . $meta_instance->inline_create_instance('$class'); - $source .= ";\n" . (join ";\n" => map { - $class->_generate_slot_initializer($meta_instance, $attrs, $_) - } 0 .. (@$attrs - 1)); - $source .= ";\n" . 'return $instance'; - $source .= ";\n" . '}'; - warn $source if $options->{debug}; - my $code = eval $source; - confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@; - return $code; -} - -sub _generate_slot_initializer { - my ($class, $meta_instance, $attrs, $index) = @_; - my $attr = $attrs->[$index]; - my $default; - if ($attr->has_default) { - # NOTE: - # default values can either be CODE refs - # in which case we need to call them. Or - # they can be scalars (strings/numbers) - # in which case we can just deal with them - # in the code we eval. - if ($attr->is_default_a_coderef) { - $default = '$attrs->[' . $index . ']->default($instance)'; - } - else { - $default = $attrs->[$index]->default; - # make sure to quote strings ... - unless (looks_like_number($default)) { - $default = "'$default'"; - } - } - } - $meta_instance->inline_set_slot_value( - '$instance', - ("'" . $attr->name . "'"), - ('$params{\'' . $attr->init_arg . '\'}' . (defined $default ? (' || ' . $default) : '')) - ) -} - # cached methods sub get_meta_instance { (shift)->{'___get_meta_instance'} } diff --git a/lib/Class/MOP/Method/Accessor.pm b/lib/Class/MOP/Method/Accessor.pm index 1c0ea40..1f8eb04 100644 --- a/lib/Class/MOP/Method/Accessor.pm +++ b/lib/Class/MOP/Method/Accessor.pm @@ -30,7 +30,7 @@ sub new { body => undef, # specific to this subclass attribute => $options{attribute}, - as_inline => ($options{as_inline} || 0), + is_inline => ($options{is_inline} || 0), accessor_type => $options{accessor_type}, } => $class; @@ -48,7 +48,7 @@ sub new { sub associated_attribute { (shift)->{attribute} } sub accessor_type { (shift)->{accessor_type} } -sub as_inline { (shift)->{as_inline} } +sub is_inline { (shift)->{is_inline} } ## factory @@ -59,7 +59,7 @@ sub intialize_body { 'generate', $self->accessor_type, 'method', - ($self->as_inline ? 'inline' : ()) + ($self->is_inline ? 'inline' : ()) ); eval { $self->{body} = $self->$method_name() }; @@ -202,7 +202,7 @@ Class::MOP::Method::Accessor - Method Meta Object for accessors =item B -=item B +=item B =item B diff --git a/lib/Class/MOP/Method/Constructor.pm b/lib/Class/MOP/Method/Constructor.pm new file mode 100644 index 0000000..7b7d921 --- /dev/null +++ b/lib/Class/MOP/Method/Constructor.pm @@ -0,0 +1,171 @@ + +package Class::MOP::Method::Constructor; + +use strict; +use warnings; + +use Carp 'confess'; +use Scalar::Util 'blessed', 'weaken', 'looks_like_number'; + +our $VERSION = '0.01'; +our $AUTHORITY = 'cpan:STEVAN'; + +use base 'Class::MOP::Method'; + +sub new { + my $class = shift; + my %options = @_; + + (exists $options{options} && ref $options{options} eq 'HASH') + || confess "You must pass a hash of options"; + + (blessed $options{meta_instance} && $options{meta_instance}->isa('Class::MOP::Instance')) + || confess "You must supply a meta-instance"; + + (exists $options{attributes} && ref $options{attributes} eq 'ARRAY') + || confess "You must pass an array of options"; + + (blessed($_) && $_->isa('Class::MOP::Attribute')) + || confess "You must supply a list of attributes which is a 'Class::MOP::Attribute' instance" + for @{$options{attributes}}; + + my $self = bless { + # from our superclass + body => undef, + # specific to this subclass + options => $options{options}, + meta_instance => $options{meta_instance}, + attributes => $options{attributes}, + } => $class; + + # we don't want this creating + # a cycle in the code, if not + # needed + weaken($self->{meta_instance}); + + $self->intialize_body; + + return $self; +} + +## accessors + +sub options { (shift)->{options} } +sub meta_instance { (shift)->{meta_instance} } +sub attributes { (shift)->{attributes} } + +## method + +sub intialize_body { + my $self = shift; + # TODO: + # the %options should also include a both + # a call 'initializer' and call 'SUPER::' + # options, which should cover approx 90% + # of the possible use cases (even if it + # requires some adaption on the part of + # the author, after all, nothing is free) + my $source = 'sub {'; + $source .= "\n" . 'my ($class, %params) = @_;'; + $source .= "\n" . 'my $instance = ' . $self->meta_instance->inline_create_instance('$class'); + $source .= ";\n" . (join ";\n" => map { + $self->_generate_slot_initializer($_) + } 0 .. (@{$self->attributes} - 1)); + $source .= ";\n" . 'return $instance'; + $source .= ";\n" . '}'; + warn $source if $self->options->{debug}; + + my $code; + { + # NOTE: + # create the nessecary lexicals + # to be picked up in the eval + my $attrs = $self->attributes; + + $code = eval $source; + confess "Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@" if $@; + } + $self->{body} = $code; +} + +sub _generate_slot_initializer { + my $self = shift; + my $index = shift; + + my $attr = $self->attributes->[$index]; + + my $default; + if ($attr->has_default) { + # NOTE: + # default values can either be CODE refs + # in which case we need to call them. Or + # they can be scalars (strings/numbers) + # in which case we can just deal with them + # in the code we eval. + if ($attr->is_default_a_coderef) { + $default = '$attrs->[' . $index . ']->default($instance)'; + } + else { + $default = $attr->default; + # make sure to quote strings ... + unless (looks_like_number($default)) { + $default = "'$default'"; + } + } + } + $self->meta_instance->inline_set_slot_value( + '$instance', + ("'" . $attr->name . "'"), + ('$params{\'' . $attr->init_arg . '\'}' . (defined $default ? (' || ' . $default) : '')) + ); +} + +1; + +1; + +__END__ + +=pod + +=head1 NAME + +Class::MOP::Method::Constructor - Method Meta Object for constructors + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=head1 METHODS + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=item B + +=back + +=head1 AUTHORS + +Stevan Little Estevan@iinteractive.comE + +Yuval Kogman Enothingmuch@woobling.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/t/000_load.t b/t/000_load.t index cb43aef..c7ba2c5 100644 --- a/t/000_load.t +++ b/t/000_load.t @@ -3,13 +3,19 @@ use strict; use warnings; -use Test::More tests => 22; +use Test::More tests => 29; BEGIN { use_ok('Class::MOP'); + use_ok('Class::MOP::Package'); + use_ok('Class::MOP::Module'); use_ok('Class::MOP::Class'); + use_ok('Class::MOP::Class::Immutable'); use_ok('Class::MOP::Attribute'); - use_ok('Class::MOP::Method'); + use_ok('Class::MOP::Method'); + use_ok('Class::MOP::Method::Wrapped'); + use_ok('Class::MOP::Method::Accessor'); + use_ok('Class::MOP::Method::Constructor'); use_ok('Class::MOP::Instance'); use_ok('Class::MOP::Object'); } @@ -18,10 +24,11 @@ BEGIN { my %METAS = ( 'Class::MOP::Attribute' => Class::MOP::Attribute->meta, - 'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta, + 'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta, + 'Class::MOP::Method::Constructor' => Class::MOP::Method::Constructor->meta, 'Class::MOP::Package' => Class::MOP::Package->meta, 'Class::MOP::Module' => Class::MOP::Module->meta, - 'Class::MOP::Class' => Class::MOP::Class->meta, + 'Class::MOP::Class' => Class::MOP::Class->meta, 'Class::MOP::Method' => Class::MOP::Method->meta, 'Class::MOP::Method::Wrapped' => Class::MOP::Method::Wrapped->meta, 'Class::MOP::Instance' => Class::MOP::Instance->meta, @@ -42,7 +49,8 @@ is_deeply( Class::MOP::Class->meta, Class::MOP::Instance->meta, Class::MOP::Method->meta, - Class::MOP::Method::Accessor->meta, + Class::MOP::Method::Accessor->meta, + Class::MOP::Method::Constructor->meta, Class::MOP::Method::Wrapped->meta, Class::MOP::Module->meta, Class::MOP::Object->meta, @@ -57,7 +65,8 @@ is_deeply( Class::MOP::Class Class::MOP::Instance Class::MOP::Method - Class::MOP::Method::Accessor + Class::MOP::Method::Accessor + Class::MOP::Method::Constructor Class::MOP::Method::Wrapped Class::MOP::Module Class::MOP::Object @@ -73,6 +82,7 @@ is_deeply( "Class::MOP::Instance-" . $Class::MOP::Instance::VERSION . "-cpan:STEVAN", "Class::MOP::Method-" . $Class::MOP::Method::VERSION . "-cpan:STEVAN", "Class::MOP::Method::Accessor-" . $Class::MOP::Method::Accessor::VERSION . "-cpan:STEVAN", + "Class::MOP::Method::Constructor-" . $Class::MOP::Method::Constructor::VERSION . "-cpan:STEVAN", "Class::MOP::Method::Wrapped-" . $Class::MOP::Method::Wrapped::VERSION . "-cpan:STEVAN", "Class::MOP::Module-" . $Class::MOP::Module::VERSION . "-cpan:STEVAN", "Class::MOP::Object-" . $Class::MOP::Object::VERSION . "-cpan:STEVAN", diff --git a/t/072_immutable_w_constructors.t b/t/072_immutable_w_constructors.t new file mode 100644 index 0000000..aeeaff6 --- /dev/null +++ b/t/072_immutable_w_constructors.t @@ -0,0 +1,242 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 76; +use Test::Exception; + +BEGIN { + use_ok('Class::MOP'); + use_ok('Class::MOP::Class::Immutable'); +} + +{ + package Foo; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->add_attribute('bar' => ( + reader => 'bar', + default => 'BAR', + )); + + package Bar; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Foo'); + + __PACKAGE__->meta->add_attribute('baz' => ( + reader => 'baz', + default => sub { 'BAZ' }, + )); + + package Baz; + + use strict; + use warnings; + use metaclass; + + __PACKAGE__->meta->superclasses('Bar'); + + __PACKAGE__->meta->add_attribute('bah' => ( + reader => 'bah', + default => 'BAH', + )); +} + +{ + my $meta = Foo->meta; + is($meta->name, 'Foo', '... checking the Foo metaclass'); + + { + my $bar_accessor = $meta->get_method('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined'); + } + + ok(!$meta->is_immutable, '... our class is not immutable'); + + lives_ok { + $meta->make_immutable( + inline_constructor => 1, + inline_accessors => 0, + ); + } '... changed Foo to be immutable'; + + ok($meta->is_immutable, '... our class is now immutable'); + isa_ok($meta, 'Class::MOP::Class::Immutable'); + isa_ok($meta, 'Class::MOP::Class'); + + # they made a constructor for us :) + can_ok('Foo', 'new'); + + { + my $foo = Foo->new; + isa_ok($foo, 'Foo'); + is($foo->bar, 'BAR', '... got the right default value'); + } + + { + my $foo = Foo->new(bar => 'BAZ'); + isa_ok($foo, 'Foo'); + is($foo->bar, 'BAZ', '... got the right parameter value'); + } + + # check out accessors too + { + my $bar_accessor = $meta->get_method('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined'); + } +} + +{ + my $meta = Bar->meta; + is($meta->name, 'Bar', '... checking the Bar metaclass'); + + { + my $bar_accessor = $meta->find_method_by_name('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined'); + + my $baz_accessor = $meta->get_method('baz'); + isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($baz_accessor, 'Class::MOP::Method'); + + ok(!$baz_accessor->is_inline, '... the baz accessor is not inlined'); + } + + ok(!$meta->is_immutable, '... our class is not immutable'); + + lives_ok { + $meta->make_immutable( + inline_constructor => 1, + inline_accessors => 1, + ); + } '... changed Bar to be immutable'; + + ok($meta->is_immutable, '... our class is now immutable'); + isa_ok($meta, 'Class::MOP::Class::Immutable'); + isa_ok($meta, 'Class::MOP::Class'); + + # they made a constructor for us :) + can_ok('Bar', 'new'); + + { + my $bar = Bar->new; + isa_ok($bar, 'Bar'); + is($bar->bar, 'BAR', '... got the right default value'); + is($bar->baz, 'BAZ', '... got the right default value'); + } + + { + my $bar = Bar->new(bar => 'BAZ!', baz => 'BAR!'); + isa_ok($bar, 'Bar'); + is($bar->bar, 'BAZ!', '... got the right parameter value'); + is($bar->baz, 'BAR!', '... got the right parameter value'); + } + + # check out accessors too + { + my $bar_accessor = $meta->find_method_by_name('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined'); + + my $baz_accessor = $meta->get_method('baz'); + isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($baz_accessor, 'Class::MOP::Method'); + + ok($baz_accessor->is_inline, '... the baz accessor is not inlined'); + } +} + +{ + my $meta = Baz->meta; + is($meta->name, 'Baz', '... checking the Bar metaclass'); + + { + my $bar_accessor = $meta->find_method_by_name('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is not inlined'); + + my $baz_accessor = $meta->find_method_by_name('baz'); + isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($baz_accessor, 'Class::MOP::Method'); + + ok($baz_accessor->is_inline, '... the baz accessor is inlined'); + + my $bah_accessor = $meta->get_method('bah'); + isa_ok($bah_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bah_accessor, 'Class::MOP::Method'); + + ok(!$bah_accessor->is_inline, '... the baz accessor is not inlined'); + } + + ok(!$meta->is_immutable, '... our class is not immutable'); + + lives_ok { + $meta->make_immutable( + inline_constructor => 0, + inline_accessors => 1, + ); + } '... changed Bar to be immutable'; + + ok($meta->is_immutable, '... our class is now immutable'); + isa_ok($meta, 'Class::MOP::Class::Immutable'); + isa_ok($meta, 'Class::MOP::Class'); + + ok(!Baz->meta->has_method('new'), '... no constructor was made'); + + { + my $baz = Baz->meta->construct_instance; + isa_ok($baz, 'Bar'); + is($baz->bar, 'BAR', '... got the right default value'); + is($baz->baz, 'BAZ', '... got the right default value'); + } + + { + my $baz = Baz->meta->construct_instance(bar => 'BAZ!', baz => 'BAR!', bah => 'BAH!'); + isa_ok($baz, 'Baz'); + is($baz->bar, 'BAZ!', '... got the right parameter value'); + is($baz->baz, 'BAR!', '... got the right parameter value'); + is($baz->bah, 'BAH!', '... got the right parameter value'); + } + + # check out accessors too + { + my $bar_accessor = $meta->find_method_by_name('bar'); + isa_ok($bar_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bar_accessor, 'Class::MOP::Method'); + + ok(!$bar_accessor->is_inline, '... the bar accessor is still not inlined'); + + my $baz_accessor = $meta->find_method_by_name('baz'); + isa_ok($baz_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($baz_accessor, 'Class::MOP::Method'); + + ok($baz_accessor->is_inline, '... the baz accessor is not inlined'); + + my $bah_accessor = $meta->get_method('bah'); + isa_ok($bah_accessor, 'Class::MOP::Method::Accessor'); + isa_ok($bah_accessor, 'Class::MOP::Method'); + + ok($bah_accessor->is_inline, '... the baz accessor is not inlined'); + } +} +