From: Stevan Little Date: Fri, 3 Feb 2006 21:22:59 +0000 (+0000) Subject: more stuff X-Git-Tag: 0_04~2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d6fbcd05c5a7e4bb8a947a603878f3a08b2f5bee;p=gitmo%2FClass-MOP.git more stuff --- diff --git a/Changes b/Changes index 2148063..9e61249 100644 --- a/Changes +++ b/Changes @@ -1,7 +1,16 @@ Revision history for Perl extension Class-MOP. 0.04 - - some documentation suggestions from #perl6 + * Class::MOP::Class + - some documentation suggestions from #perl6 + + * Class::MOP::Attribute + - improved error messages + + * examples/ + - added new examples: + - AttributesWithHistory + - 0.03 Fri Feb. 3, 2006 - converted to Module::Build instead of EU::MM diff --git a/examples/AttributesWithHistory.pod b/examples/AttributesWithHistory.pod index 0061171..7039c5a 100644 --- a/examples/AttributesWithHistory.pod +++ b/examples/AttributesWithHistory.pod @@ -97,7 +97,7 @@ AttributesWithHistory - An example attribute metaclass which keeps a history of sub new { my $class = shift; - bless $class->meta->construct_instance() => $class; + bless $class->meta->construct_instance(@_) => $class; } =head1 DESCRIPTION @@ -122,4 +122,3 @@ This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut - diff --git a/examples/ClassEncapsulatedAttributes.pod b/examples/ClassEncapsulatedAttributes.pod new file mode 100644 index 0000000..030fdb4 --- /dev/null +++ b/examples/ClassEncapsulatedAttributes.pod @@ -0,0 +1,160 @@ + +package # hide the package from PAUSE + ClassEncapsulatedAttributes; + +use strict; +use warnings; + +use Class::MOP 'meta'; + +our $VERSION = '0.01'; + +use base 'Class::MOP::Class'; + +sub construct_instance { + my ($class, %params) = @_; + #use Data::Dumper; warn Dumper \%params; + my $instance = {}; + foreach my $current_class ($class->class_precedence_list()) { + $instance->{$current_class} = {} + unless exists $instance->{$current_class}; + my $meta = $class->initialize($current_class); + foreach my $attr_name ($meta->get_attribute_list()) { + my $attr = $meta->get_attribute($attr_name); + # 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; + # try to fetch the init arg from the %params ... + my $val; + $val = $params{$current_class}->{$init_arg} + if exists $params{$current_class} && + exists ${$params{$current_class}}{$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 + $instance->{$current_class}->{$attr_name} = $val; + } + } + #use Data::Dumper; warn Dumper $instance; + return $instance; +} + +package # hide the package from PAUSE + ClassEncapsulatedAttributes::Attribute; + +use strict; +use warnings; + +use Class::MOP 'meta'; + +our $VERSION = '0.01'; + +use base 'Class::MOP::Attribute'; + +sub generate_accessor_method { + my ($self, $attr_name) = @_; + my $class_name = $self->associated_class->name; + eval qq{sub { + \$_[0]->{'$class_name'}->{'$attr_name'} = \$_[1] if scalar(\@_) == 2; + \$_[0]->{'$class_name'}->{'$attr_name'}; + }}; +} + +sub generate_reader_method { + my ($self, $attr_name) = @_; + my $class_name = $self->associated_class->name; + eval qq{sub { + \$_[0]->{'$class_name'}->{'$attr_name'}; + }}; +} + +sub generate_writer_method { + my ($self, $attr_name) = @_; + my $class_name = $self->associated_class->name; + eval qq{sub { + \$_[0]->{'$class_name'}->{'$attr_name'} = \$_[1]; + }}; +} + +sub generate_predicate_method { + my ($self, $attr_name) = @_; + my $class_name = $self->associated_class->name; + eval qq{sub { + defined \$_[0]->{'$class_name'}->{'$attr_name'} ? 1 : 0; + }}; +} + +## &remove_attribute is left as an exercise for the reader :) + +1; + +__END__ + +=pod + +=head1 NAME + +ClassEncapsulatedAttributes - A set of example metaclasses with class encapsulated attributes + +=head1 SYNOPSIS + + package Foo; + + sub meta { ClassEncapsulatedAttributes->initialize($_[0]) } + + Foo->meta->add_attribute( + ClassEncapsulatedAttributes::Attribute->new('foo' => ( + accessor => 'Foo_foo', + default => 'init in FOO' + )) + ); + + sub new { + my $class = shift; + bless $class->meta->construct_instance(@_) => $class; + } + + package Bar; + our @ISA = ('Foo'); + + # duplicate the attribute name here + Bar->meta->add_attribute( + ClassEncapsulatedAttributes::Attribute->new('foo' => ( + accessor => 'Bar_foo', + default => 'init in BAR' + )) + ); + + # ... later in other code ... + + my $bar = Bar->new(); + prints $bar->Bar_foo(); # init in BAR + prints $bar->Foo_foo(); # init in FOO + + # and ... + + my $bar = Bar->new( + 'Foo' => { 'foo' => 'Foo::foo' }, + 'Bar' => { 'foo' => 'Bar::foo' } + ); + + prints $bar->Bar_foo(); # Foo::foo + prints $bar->Foo_foo(); # Bar::foo + +=head1 DESCRIPTION + +=head1 AUTHOR + +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/examples/InsideOutClass.pod b/examples/InsideOutClass.pod index 17f9044..dfb38d2 100644 --- a/examples/InsideOutClass.pod +++ b/examples/InsideOutClass.pod @@ -105,7 +105,7 @@ InsideOutClass - A set of example metaclasses which implement the Inside-Out tec sub new { my $class = shift; - bless $class->meta->construct_instance() => $class; + bless $class->meta->construct_instance(@_) => $class; } # now you can just use the class as normal diff --git a/examples/InstanceCountingClass.pod b/examples/InstanceCountingClass.pod index 93ba4d5..614303e 100644 --- a/examples/InstanceCountingClass.pod +++ b/examples/InstanceCountingClass.pod @@ -41,7 +41,7 @@ InstanceCountingClass - An example metaclass which counts instances sub meta { InstanceCountingClass->initialize($_[0]) } sub new { my $class = shift; - bless $class->meta->construct_instance() => $class; + bless $class->meta->construct_instance(@_) => $class; } # ... meanwhile, somewhere in the code diff --git a/examples/Perl6Attribute.pod b/examples/Perl6Attribute.pod index 47c93f9..95cf71b 100644 --- a/examples/Perl6Attribute.pod +++ b/examples/Perl6Attribute.pod @@ -47,7 +47,7 @@ Perl6Attribute - An example attribute metaclass for Perl 6 style attributes sub new { my $class = shift; - bless $class->meta->construct_instance() => $class; + bless $class->meta->construct_instance(@_) => $class; } =head1 DESCRIPTION diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 698ba6f..303137f 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -11,7 +11,7 @@ use Class::MOP::Class; use Class::MOP::Attribute; use Class::MOP::Method; -our $VERSION = '0.03'; +our $VERSION = '0.04'; sub import { shift; diff --git a/t/101_InstanceCountingClass_test.t b/t/101_InstanceCountingClass_test.t index 9f2215f..829ab28 100644 --- a/t/101_InstanceCountingClass_test.t +++ b/t/101_InstanceCountingClass_test.t @@ -26,7 +26,7 @@ a simple demonstration of how to make a metaclass. sub meta { InstanceCountingClass->initialize($_[0]) } sub new { my $class = shift; - bless $class->meta->construct_instance() => $class; + bless $class->meta->construct_instance(@_) => $class; } package Bar; diff --git a/t/102_InsideOutClass_test.t b/t/102_InsideOutClass_test.t index a8cd234..6510ca7 100644 --- a/t/102_InsideOutClass_test.t +++ b/t/102_InsideOutClass_test.t @@ -33,7 +33,7 @@ BEGIN { sub new { my $class = shift; - bless $class->meta->construct_instance() => $class; + bless $class->meta->construct_instance(@_) => $class; } } diff --git a/t/103_Perl6Attribute_test.t b/t/103_Perl6Attribute_test.t index 90772f0..84e1ea9 100644 --- a/t/103_Perl6Attribute_test.t +++ b/t/103_Perl6Attribute_test.t @@ -22,7 +22,7 @@ BEGIN { sub new { my $class = shift; - bless $class->meta->construct_instance() => $class; + bless $class->meta->construct_instance(@_) => $class; } } diff --git a/t/104_AttributesWithHistory_test.t b/t/104_AttributesWithHistory_test.t index 702162e..ada9d67 100644 --- a/t/104_AttributesWithHistory_test.t +++ b/t/104_AttributesWithHistory_test.t @@ -29,7 +29,7 @@ BEGIN { sub new { my $class = shift; - bless $class->meta->construct_instance() => $class; + bless $class->meta->construct_instance(@_) => $class; } } diff --git a/t/105_ClassEncapsulatedAttributes_test.t b/t/105_ClassEncapsulatedAttributes_test.t new file mode 100644 index 0000000..199b4c2 --- /dev/null +++ b/t/105_ClassEncapsulatedAttributes_test.t @@ -0,0 +1,117 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 29; +use File::Spec; + +BEGIN { + use_ok('Class::MOP'); + require_ok(File::Spec->catdir('examples', 'ClassEncapsulatedAttributes.pod')); +} + +{ + package Foo; + + sub meta { ClassEncapsulatedAttributes->initialize($_[0]) } + + Foo->meta->add_attribute( + ClassEncapsulatedAttributes::Attribute->new('foo' => ( + accessor => 'foo', + predicate => 'has_foo', + default => 'init in FOO' + )) + ); + + Foo->meta->add_attribute( + ClassEncapsulatedAttributes::Attribute->new('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + default => 'init in FOO' + )) + ); + + sub new { + my $class = shift; + bless $class->meta->construct_instance(@_) => $class; + } + + package Bar; + our @ISA = ('Foo'); + + Bar->meta->add_attribute( + ClassEncapsulatedAttributes::Attribute->new('foo' => ( + accessor => 'foo', + predicate => 'has_foo', + default => 'init in BAR' + )) + ); + + Bar->meta->add_attribute( + ClassEncapsulatedAttributes::Attribute->new('bar' => ( + reader => 'get_bar', + writer => 'set_bar', + default => 'init in BAR' + )) + ); + + sub SUPER_foo { (shift)->SUPER::foo(@_) } + sub SUPER_has_foo { (shift)->SUPER::foo(@_) } + sub SUPER_get_bar { (shift)->SUPER::get_bar() } + sub SUPER_set_bar { (shift)->SUPER::set_bar(@_) } + +} + +{ + my $foo = Foo->new(); + isa_ok($foo, 'Foo'); + + can_ok($foo, 'foo'); + can_ok($foo, 'has_foo'); + can_ok($foo, 'get_bar'); + can_ok($foo, 'set_bar'); + + my $bar = Bar->new(); + isa_ok($bar, 'Bar'); + + can_ok($bar, 'foo'); + can_ok($bar, 'has_foo'); + can_ok($bar, 'get_bar'); + can_ok($bar, 'set_bar'); + + ok($foo->has_foo, '... Foo::has_foo == 1'); + ok($bar->has_foo, '... Bar::has_foo == 1'); + + is($foo->foo, 'init in FOO', '... got the right default value for Foo::foo'); + is($bar->foo, 'init in BAR', '... got the right default value for Bar::foo'); + + is($bar->SUPER_foo(), 'init in FOO', '... got the right default value for Bar::SUPER::foo'); + + $bar->SUPER_foo(undef); + + is($bar->SUPER_foo(), undef, '... successfully set Foo::foo through Bar::SUPER::foo'); + ok(!$bar->SUPER_has_foo, '... BAR::SUPER::has_foo == 0'); + + ok($foo->has_foo, '... Foo::has_foo (is still) 1'); +} + +{ + my $bar = Bar->new( + 'Foo' => { 'foo' => 'Foo::foo' }, + 'Bar' => { 'foo' => 'Bar::foo' } + ); + isa_ok($bar, 'Bar'); + + can_ok($bar, 'foo'); + can_ok($bar, 'has_foo'); + can_ok($bar, 'get_bar'); + can_ok($bar, 'set_bar'); + + ok($bar->has_foo, '... Bar::has_foo == 1'); + ok($bar->SUPER_has_foo, '... Bar::SUPER_has_foo == 1'); + + is($bar->foo, 'Bar::foo', '... got the right default value for Bar::foo'); + is($bar->SUPER_foo(), 'Foo::foo', '... got the right default value for Bar::SUPER::foo'); +} +