From: Stevan Little Date: Thu, 2 Nov 2006 13:40:23 +0000 (+0000) Subject: testing X-Git-Tag: 0_36^0 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=fdbdb5e6eb0e4f6c54629f0bde376aba5e69df14;p=gitmo%2FClass-MOP.git testing --- diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index adbccfa..66db0e2 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -373,56 +373,6 @@ 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: @@ -462,8 +412,7 @@ $_->meta->make_immutable( Class::MOP::Object Class::MOP::Method::Accessor - Class::MOP::Method::Constructor - Class::MOP::Method::Wrapped + Class::MOP::Method::Wrapped /; 1; diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 376b9b1..c8ab6c0 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, - is_inline => $inline_me, + as_inline => $inline_me, accessor_type => $type, ); }; diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 96d1402..afd2789 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -70,6 +70,7 @@ sub construct_class_instance { : blessed($class)) : $class); + $class = blessed($class) || $class; # now create the metaclass my $meta; if ($class =~ /^Class::MOP::Class$/) { diff --git a/lib/Class/MOP/Class/Immutable.pm b/lib/Class/MOP/Class/Immutable.pm index 0f58927..942708c 100644 --- a/lib/Class/MOP/Class/Immutable.pm +++ b/lib/Class/MOP/Class/Immutable.pm @@ -4,10 +4,8 @@ package Class::MOP::Class::Immutable; use strict; use warnings; -use Class::MOP::Method::Constructor; - use Carp 'confess'; -use Scalar::Util 'blessed'; +use Scalar::Util 'blessed', 'looks_like_number'; our $VERSION = '0.03'; our $AUTHORITY = 'cpan:STEVAN'; @@ -43,6 +41,19 @@ for my $meth (qw( }; } +sub get_package_symbol { + my ($self, $variable) = @_; + my ($name, $sigil, $type) = $self->_deconstruct_variable_name($variable); + return *{$self->namespace->{$name}}{$type} + if exists $self->namespace->{$name}; + # NOTE: + # we have to do this here in order to preserve + # perl's autovivification of variables. However + # we do cut off direct access to add_package_symbol + # as shown above. + $self->Class::MOP::Package::add_package_symbol($variable); +} + # NOTE: # superclasses is an accessor, so # it just cannot be changed @@ -77,37 +88,87 @@ sub make_metaclass_immutable { if ($options{inline_accessors}) { foreach my $attr_name ($metaclass->get_attribute_list) { - # inline the accessors - $metaclass->get_attribute($attr_name) - ->install_accessors(1); + my $attr = $metaclass->get_attribute($attr_name); + $attr->install_accessors(1); # inline the accessors } } if ($options{inline_constructor}) { - my $constructor_class = $options{constructor_class} || 'Class::MOP::Method::Constructor'; $metaclass->add_method( $options{constructor_name}, - $constructor_class->new( - options => \%options, - meta_instance => $meta_instance, - attributes => $metaclass->{'___compute_all_applicable_attributes'} - ) + $class->_generate_inline_constructor( + \%options, + $meta_instance, + $metaclass->{'___compute_all_applicable_attributes'} + ) ); } # now cache the method map ... - $metaclass->{'___get_method_map'} = $metaclass->get_method_map; + $metaclass->{'___method_map'} = $metaclass->get_method_map; 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'} } sub class_precedence_list { @{(shift)->{'___class_precedence_list'}} } sub compute_all_applicable_attributes { @{(shift)->{'___compute_all_applicable_attributes'}} } sub get_mutable_metaclass_name { (shift)->{'___original_class'} } -sub get_method_map { (shift)->{'___get_method_map'} } +sub get_method_map { (shift)->{'___method_map'} } 1; @@ -228,6 +289,11 @@ to this method, which This method becomes read-only in an immutable class. +=item B + +This method must handle package variable autovivification +correctly, while still disallowing C. + =back =head2 Cached methods diff --git a/lib/Class/MOP/Method/Accessor.pm b/lib/Class/MOP/Method/Accessor.pm index 237dd0e..1c0ea40 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}, - is_inline => ($options{is_inline} || 0), + as_inline => ($options{as_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 is_inline { (shift)->{is_inline} } +sub as_inline { (shift)->{as_inline} } ## factory @@ -59,7 +59,7 @@ sub intialize_body { 'generate', $self->accessor_type, 'method', - ($self->is_inline ? 'inline' : ()) + ($self->as_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 @@ -232,6 +232,8 @@ Class::MOP::Method::Accessor - Method Meta Object for accessors Stevan Little Estevan@iinteractive.comE +Yuval Kogman Enothingmuch@woobling.comE + =head1 COPYRIGHT AND LICENSE Copyright 2006 by Infinity Interactive, Inc. diff --git a/lib/Class/MOP/Method/Constructor.pm b/lib/Class/MOP/Method/Constructor.pm deleted file mode 100644 index 08812bc..0000000 --- a/lib/Class/MOP/Method/Constructor.pm +++ /dev/null @@ -1,169 +0,0 @@ - -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 - -=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 c7ba2c5..cb43aef 100644 --- a/t/000_load.t +++ b/t/000_load.t @@ -3,19 +3,13 @@ use strict; use warnings; -use Test::More tests => 29; +use Test::More tests => 22; 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::Wrapped'); - use_ok('Class::MOP::Method::Accessor'); - use_ok('Class::MOP::Method::Constructor'); + use_ok('Class::MOP::Method'); use_ok('Class::MOP::Instance'); use_ok('Class::MOP::Object'); } @@ -24,11 +18,10 @@ BEGIN { my %METAS = ( 'Class::MOP::Attribute' => Class::MOP::Attribute->meta, - 'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta, - 'Class::MOP::Method::Constructor' => Class::MOP::Method::Constructor->meta, + 'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->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, @@ -49,8 +42,7 @@ is_deeply( Class::MOP::Class->meta, Class::MOP::Instance->meta, Class::MOP::Method->meta, - Class::MOP::Method::Accessor->meta, - Class::MOP::Method::Constructor->meta, + Class::MOP::Method::Accessor->meta, Class::MOP::Method::Wrapped->meta, Class::MOP::Module->meta, Class::MOP::Object->meta, @@ -65,8 +57,7 @@ is_deeply( Class::MOP::Class Class::MOP::Instance Class::MOP::Method - Class::MOP::Method::Accessor - Class::MOP::Method::Constructor + Class::MOP::Method::Accessor Class::MOP::Method::Wrapped Class::MOP::Module Class::MOP::Object @@ -82,7 +73,6 @@ 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 deleted file mode 100644 index aeeaff6..0000000 --- a/t/072_immutable_w_constructors.t +++ /dev/null @@ -1,242 +0,0 @@ -#!/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'); - } -} -