From: Stevan Little Date: Sun, 5 Feb 2006 16:15:41 +0000 (+0000) Subject: a number of changes; X-Git-Tag: 0_06~10 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c9e77dbb017258dc44295fc4ec8e0bdd99ec9361;p=gitmo%2FClass-MOP.git a number of changes; --- diff --git a/Changes b/Changes index bae52de..6a9afbb 100644 --- a/Changes +++ b/Changes @@ -8,6 +8,11 @@ Revision history for Perl extension Class-MOP. * Class::MOP::Class - fixing minor meta-circularity issue with &meta, it is now more useful for subclasses + - &compute_all_applicable_attributes now just returns + the attribute meta-object, rather than the HASH ref + since all the same info can be gotten from the + attribute meta-object itself + - updated docs & tests to reflect * examples/ - adjusting code to use the &Class::MOP::Class::meta diff --git a/examples/InsideOutClass.pod b/examples/InsideOutClass.pod index 781370e..5ea7e78 100644 --- a/examples/InsideOutClass.pod +++ b/examples/InsideOutClass.pod @@ -16,7 +16,7 @@ sub construct_instance { # create a scalar ref to use as # the inside-out instance my $instance = \(my $var); - foreach my $attr (map { $_->{attribute} } $class->compute_all_applicable_attributes()) { + foreach my $attr ($class->compute_all_applicable_attributes()) { # if the attr has an init_arg, use that, otherwise, # use the attributes name itself as the init_arg my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name; diff --git a/examples/LazyClass.pod b/examples/LazyClass.pod index 8aaa30c..cb678b1 100644 --- a/examples/LazyClass.pod +++ b/examples/LazyClass.pod @@ -12,7 +12,7 @@ use base 'Class::MOP::Class'; sub construct_instance { my ($class, %params) = @_; my $instance = {}; - foreach my $attr (map { $_->{attribute} } $class->compute_all_applicable_attributes()) { + foreach my $attr ($class->compute_all_applicable_attributes()) { # if the attr has an init_arg, use that, otherwise, # use the attributes name itself as the init_arg my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name; diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 6286361..5f68dfd 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -100,7 +100,7 @@ Class::MOP::Attribute->meta->add_method('new' => sub { || confess "You cannot declare an accessor and reader and/or writer functions" if exists $options{accessor}; - bless $class->meta->construct_instance(name => $name, %options) => $class; + bless $class->meta->construct_instance(name => $name, %options) => blessed($class) || $class; }); 1; diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 410bacb..8dc94d6 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -27,7 +27,9 @@ sub meta { Class::MOP::Class->initialize($_[0]) } my $class = shift; my $package_name = shift; (defined $package_name && $package_name) - || confess "You must pass a package name"; + || confess "You must pass a package name"; + # make sure the package name is not blessed + $package_name = blessed($package_name) || $package_name; return $METAS{$package_name} if exists $METAS{$package_name}; $METAS{$package_name} = $class->construct_class_instance($package_name, @_); } @@ -88,27 +90,44 @@ sub create { return $meta; } -# Instance Construction +# Instance Construction & Cloning + sub construct_instance { my ($class, %params) = @_; my $instance = {}; - foreach my $attr (map { $_->{attribute} } $class->compute_all_applicable_attributes()) { - # if the attr has an init_arg, use that, otherwise, - # use the attributes name itself as the init_arg + foreach my $attr ($class->compute_all_applicable_attributes()) { my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name; # try to fetch the init arg from the %params ... my $val; $val = $params{$init_arg} if exists $params{$init_arg}; # if nothing was in the %params, we can use the # attribute's default value (if it has one) - $val ||= $attr->default($instance) if $attr->has_default(); - # now add this to the instance structure + $val ||= $attr->default($instance) if $attr->has_default(); $instance->{$attr->name} = $val; } return $instance; } +sub clone_instance { + my ($class, $self, %params) = @_; + (blessed($self)) + || confess "You can only clone instances, \$self is not a blessed instance"; + # NOTE: + # this should actually do a deep clone + # instead of this cheap hack. I will + # add that in later. + # (use the Class::Cloneable::Util code) + my $clone = { %{$self} }; + foreach my $attr ($class->compute_all_applicable_attributes()) { + my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name; + # try to fetch the init arg from the %params ... + $clone->{$attr->name} = $params{$init_arg} + if exists $params{$init_arg}; + } + return $clone; +} + # Informational sub name { $_[0]->{'$:package'} } @@ -336,11 +355,7 @@ sub compute_all_applicable_attributes { foreach my $attr_name ($meta->get_attribute_list()) { next if exists $seen_attr{$attr_name}; $seen_attr{$attr_name}++; - push @attrs => { - name => $attr_name, - class => $class, - attribute => $meta->get_attribute($attr_name) - }; + push @attrs => $meta->get_attribute($attr_name); } } return @attrs; @@ -504,19 +519,19 @@ from outside of that method really. =back -=head2 Object instance construction - -This method is used to construct an instace structure suitable for -C-ing into your package of choice. It works in conjunction -with the Attribute protocol to collect all applicable attributes. +=head2 Object instance construction and cloning -This method is B, it is up to you whether you want -to use it or not. +These methods are B, it is up to you whether you want +to use them or not. =over 4 =item B +This method is used to construct an instace structure suitable for +C-ing into your package of choice. It works in conjunction +with the Attribute protocol to collect all applicable attributes. + This will construct and instance using a HASH ref as storage (currently only HASH references are supported). This will collect all the applicable attributes and layout out the fields in the HASH ref, @@ -524,6 +539,18 @@ it will then initialize them using either use the corresponding key in C<%params> or any default value or initializer found in the attribute meta-object. +=item B + +This method is a compliment of C (which means if +you override C, you need to override this one too). + +This method will clone the C<$instance> structure created by the +C method, and apply any C<%params> passed to it +to change the attribute values. The structure returned is (like with +C) an unCed HASH reference, it is your +responsibility to then bless this cloned structure into the right +class. + =back =head2 Informational @@ -711,11 +738,11 @@ use the C method. =item B -This will traverse the inheritance heirachy and return a list of HASH -references for all the applicable attributes for this class. The HASH -references will contain the following information; the attribute name, -the class which the attribute is associated with and the actual -attribute meta-object. +This will traverse the inheritance heirachy and return a list of all +the applicable attributes for this class. It does not construct a +HASH reference like C because all +that same information is discoverable through the attribute +meta-object itself. =back diff --git a/lib/metaclass.pm b/lib/metaclass.pm index f9f0b75..917459f 100644 --- a/lib/metaclass.pm +++ b/lib/metaclass.pm @@ -12,7 +12,7 @@ use Class::MOP; sub import { shift; - my $metaclass = shift; + my $metaclass = shift || 'Class::MOP::Class'; my %options = @_; my $package = caller(); @@ -31,6 +31,50 @@ sub import { }); } +=pod + +NOTES + +Okay, the metaclass constraint issue is a bit of a PITA. + +Especially in the context of MI, where we end up with an +explosion of metaclasses. + +SOOOO + +Instead of auto-composing metaclasses using inheritance +(which is problematic at best, and totally wrong at worst, +especially in the light of methods of Class::MOP::Class +which are overridden by subclasses (try to figure out how +LazyClass and InsideOutClass could be composed, it is not +even possible)) we use a trait model. + +It will be similar to Class::Trait, except that there is +no such thing as a trait, a class isa trait and a trait +isa class, more like Scala really. + +This way we get several benefits: + +1) Classes can be composed like traits, and it Just Works. + +2) Metaclasses can be composed this way too :) + +3) When solving the metaclass constraint, we create an + anon-metaclass, and compose the parent's metaclasses + into it. This allows for conflict checking trait-style + which should inform us of any issues right away. + +Misc. Details: + +Class metaclasses must be composed, but so must any +associated Attribute and Method metaclasses. However, this +is not always relevant since I should be able to create a +class which has lazy attributes, and then create a subclass +of that class whose attributes are not lazy. + + +=cut + 1; __END__ @@ -52,6 +96,9 @@ metaclass - a pragma for installing using Class::MOP metaclasses =head1 DESCRIPTION +This is a pragma to make it easier to use a specific metaclass +and it's + =head1 AUTHOR Stevan Little Estevan@iinteractive.comE diff --git a/t/005_attributes.t b/t/005_attributes.t index 0779a77..9615c0b 100644 --- a/t/005_attributes.t +++ b/t/005_attributes.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 30; +use Test::More tests => 33; use Test::Exception; BEGIN { @@ -68,25 +68,18 @@ my $BAZ_ATTR = Class::MOP::Attribute->new('$baz' => ( isa_ok($meta, 'Class::MOP::Class'); is_deeply( - [ sort { $a->{name} cmp $b->{name} } $meta->compute_all_applicable_attributes() ], + [ sort { $a->name cmp $b->name } $meta->compute_all_applicable_attributes() ], [ - { - name => '$bar', - class => 'Bar', - attribute => $BAR_ATTR - }, - { - name => '$baz', - class => 'Baz', - attribute => $BAZ_ATTR - }, - { - name => '$foo', - class => 'Foo', - attribute => $FOO_ATTR - }, + $BAR_ATTR, + $BAZ_ATTR, + $FOO_ATTR, ], '... got the right list of applicable attributes for Baz'); + + is_deeply( + [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->compute_all_applicable_attributes() ], + [ Bar->meta, Baz->meta, Foo->meta ], + '... got the right list of associated classes from the applicable attributes for Baz'); my $attr; lives_ok { @@ -100,21 +93,18 @@ my $BAZ_ATTR = Class::MOP::Attribute->new('$baz' => ( ok(!$meta->has_method('set_baz'), '... a writer has been removed'); is_deeply( - [ sort { $a->{name} cmp $b->{name} } $meta->compute_all_applicable_attributes() ], + [ sort { $a->name cmp $b->name } $meta->compute_all_applicable_attributes() ], [ - { - name => '$bar', - class => 'Bar', - attribute => $BAR_ATTR - }, - { - name => '$foo', - class => 'Foo', - attribute => $FOO_ATTR - }, + $BAR_ATTR, + $FOO_ATTR, ], '... got the right list of applicable attributes for Baz'); + is_deeply( + [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->compute_all_applicable_attributes() ], + [ Bar->meta, Foo->meta ], + '... got the right list of associated classes from the applicable attributes for Baz'); + { my $attr; lives_ok { @@ -128,14 +118,15 @@ my $BAZ_ATTR = Class::MOP::Attribute->new('$baz' => ( } is_deeply( - [ sort { $a->{name} cmp $b->{name} } $meta->compute_all_applicable_attributes() ], + [ sort { $a->name cmp $b->name } $meta->compute_all_applicable_attributes() ], [ - { - name => '$foo', - class => 'Foo', - attribute => $FOO_ATTR - }, + $FOO_ATTR, ], '... got the right list of applicable attributes for Baz'); + is_deeply( + [ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->compute_all_applicable_attributes() ], + [ Foo->meta ], + '... got the right list of associated classes from the applicable attributes for Baz'); + } diff --git a/t/103_Perl6Attribute_test.t b/t/103_Perl6Attribute_test.t index 84e1ea9..8ad155c 100644 --- a/t/103_Perl6Attribute_test.t +++ b/t/103_Perl6Attribute_test.t @@ -14,7 +14,7 @@ BEGIN { { package Foo; - use Class::MOP 'meta'; + use metaclass; Foo->meta->add_attribute(Perl6Attribute->new('$.foo')); Foo->meta->add_attribute(Perl6Attribute->new('@.bar'));