From: Stevan Little Date: Fri, 3 Feb 2006 16:08:03 +0000 (+0000) Subject: - refactoring attributes X-Git-Tag: 0_04~6 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=9ec169fe90e11be6be8ad2e2e25fa49f82ce72c2;p=gitmo%2FClass-MOP.git - refactoring attributes - refactoring examples to use those - changed examples to .pod files and hide the packages from the PAUSE indexer --- diff --git a/Build.PL b/Build.PL index ba72ec8..fc60d93 100644 --- a/Build.PL +++ b/Build.PL @@ -16,6 +16,7 @@ my $build = Module::Build->new( build_requires => { 'Test::More' => '0.47', 'Test::Exception' => '0.21', + 'File::Spec' => 0, }, create_makefile_pl => 'traditional', recursive_test_files => 1, diff --git a/Changes b/Changes index f9eec5d..b4116b3 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,16 @@ Revision history for Perl extension Class-MOP. +0.03 Fri Feb. 3, 2006 + - converted to Module::Build instead of EU::MM + + * Class::MOP::Attribute + - refactored method generation code + - attributes are now associated with class directly + + * examples + - refactored the InsideOut example to take advantage + of the Class::MOP::Attribute refactoring + 0.02 Thurs Feb. 2, 2006 - moving examples from t/lib/* to examples/* - adding POD documentation to the examples diff --git a/MANIFEST b/MANIFEST index 35e0a89..56b152a 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4,9 +4,9 @@ Makefile.PL MANIFEST README META.yml -examples/InsideOutClass.pm -examples/InstanceCountingClass.pm -examples/Perl6Attribute.pm +examples/InsideOutClass.pod +examples/InstanceCountingClass.pod +examples/Perl6Attribute.pod lib/Class/MOP.pm lib/Class/MOP/Attribute.pm lib/Class/MOP/Class.pm diff --git a/examples/InsideOutClass.pm b/examples/InsideOutClass.pm deleted file mode 100644 index 78d1df3..0000000 --- a/examples/InsideOutClass.pm +++ /dev/null @@ -1,179 +0,0 @@ - -package InsideOutClass; - -use strict; -use warnings; - -use Class::MOP 'meta'; - -our $VERSION = '0.02'; - -use Scalar::Util 'refaddr'; - -use base 'Class::MOP::Class'; - -sub construct_instance { - my ($class, %params) = @_; - # 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()) { - # 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{$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 - $class->get_package_variable('%' . $attr->name)->{ refaddr($instance) } = $val; - } - return $instance; -} - -package InsideOutClass::Attribute; - -use strict; -use warnings; - -use Class::MOP 'meta'; - -our $VERSION = '0.02'; - -use Carp 'confess'; -use Scalar::Util 'blessed', 'reftype', 'refaddr'; - -use base 'Class::MOP::Attribute'; - -{ - # this is just a utility routine to - # handle the details of accessors - my $_inspect_accessor = sub { - my ($attr_name, $type, $accessor) = @_; - my %ACCESSOR_TEMPLATES = ( - 'accessor' => 'sub { - $' . $attr_name . '{ refaddr($_[0]) } = $_[1] if scalar(@_) == 2; - $' . $attr_name . '{ refaddr($_[0]) }; - }', - 'reader' => 'sub { - $' . $attr_name . '{ refaddr($_[0]) }; - }', - 'writer' => 'sub { - $' . $attr_name . '{ refaddr($_[0]) } = $_[1]; - }', - 'predicate' => 'sub { - defined($' . $attr_name . '{ refaddr($_[0]) }) ? 1 : 0; - }' - ); - - my $method = eval $ACCESSOR_TEMPLATES{$type}; - confess "Could not create the $type for $attr_name CODE(\n" . $ACCESSOR_TEMPLATES{$type} . "\n) : $@" if $@; - return ($accessor => Class::MOP::Attribute::Accessor->wrap($method)); - }; - - sub install_accessors { - my ($self, $class) = @_; - (blessed($class) && $class->isa('Class::MOP::Class')) - || confess "You must pass a Class::MOP::Class instance (or a subclass)"; - - # create the package variable to - # store the inside out attribute - $class->add_package_variable('%' . $self->name); - - # now create the accessor/reader/writer/predicate methods - - $class->add_method( - $_inspect_accessor->($class->name . '::' . $self->name, 'accessor' => $self->accessor()) - ) if $self->has_accessor(); - - $class->add_method( - $_inspect_accessor->($class->name . '::' . $self->name, 'reader' => $self->reader()) - ) if $self->has_reader(); - - $class->add_method( - $_inspect_accessor->($class->name . '::' . $self->name, 'writer' => $self->writer()) - ) if $self->has_writer(); - - $class->add_method( - $_inspect_accessor->($class->name . '::' . $self->name, 'predicate' => $self->predicate()) - ) if $self->has_predicate(); - return; - } - -} - -## &remove_attribute is left as an exercise for the reader :) - -1; - -__END__ - -=pod - -=head1 NAME - -InsideOutClass - A set of metaclasses which use the Inside-Out technique - -=head1 SYNOPSIS - - package Foo; - - sub meta { InsideOutClass->initialize($_[0]) } - - __PACKAGE__->meta->add_attribute( - InsideOutClass::Attribute->new('foo' => ( - reader => 'get_foo', - writer => 'set_foo' - )) - ); - - sub new { - my $class = shift; - bless $class->meta->construct_instance() => $class; - } - - # now you can just use the class as normal - -=head1 DESCRIPTION - -This is a set of example metaclasses which implement the Inside-Out -class technique. What follows is a brief explaination of the code -found in this module. - -First step is to subclass B and override the -C method. The default C -will create a HASH reference using the parameters and attribute -default values. Since inside-out objects don't use HASH refs, and -use package variables instead, we need to write code to handle -this difference. - -The next step is to create the subclass of B -and override the C method (you would also need to -override the C too, but we can safely ignore that -in our example). The C method is called by the -C method of B, and will install -the accessors for your attribute. Since inside-out objects require -different types of accessors, we need to write the code to handle -this difference as well. - -And that is pretty much all. Of course I am ignoring need for -inside-out objects to be C-ed, and some other details as -well, but this is an example. A real implementation is left as an -exercise to the reader. - -=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 new file mode 100644 index 0000000..17f9044 --- /dev/null +++ b/examples/InsideOutClass.pod @@ -0,0 +1,151 @@ + +package # hide the package from PAUSE + InsideOutClass; + +use strict; +use warnings; + +use Class::MOP 'meta'; + +our $VERSION = '0.02'; + +use Scalar::Util 'refaddr'; + +use base 'Class::MOP::Class'; + +sub construct_instance { + my ($class, %params) = @_; + # 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()) { + # 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{$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 + $class->get_package_variable('%' . $attr->name)->{ refaddr($instance) } = $val; + } + return $instance; +} + +package # hide the package from PAUSE + InsideOutClass::Attribute; + +use strict; +use warnings; + +use Class::MOP 'meta'; + +our $VERSION = '0.03'; + +use Scalar::Util 'refaddr'; + +use base 'Class::MOP::Attribute'; + +sub generate_accessor_method { + my ($self, $attr_name) = @_; + $attr_name = ($self->associated_class->name . '::' . $attr_name); + eval 'sub { + $' . $attr_name . '{ refaddr($_[0]) } = $_[1] if scalar(@_) == 2; + $' . $attr_name . '{ refaddr($_[0]) }; + }'; +} + +sub generate_reader_method { + my ($self, $attr_name) = @_; + eval 'sub { + $' . ($self->associated_class->name . '::' . $attr_name) . '{ refaddr($_[0]) }; + }'; +} + +sub generate_writer_method { + my ($self, $attr_name) = @_; + eval 'sub { + $' . ($self->associated_class->name . '::' . $attr_name) . '{ refaddr($_[0]) } = $_[1]; + }'; +} + +sub generate_predicate_method { + my ($self, $attr_name) = @_; + eval 'sub { + defined($' . ($self->associated_class->name . '::' . $attr_name) . '{ refaddr($_[0]) }) ? 1 : 0; + }'; +} + +## &remove_attribute is left as an exercise for the reader :) + +1; + +__END__ + +=pod + +=head1 NAME + +InsideOutClass - A set of example metaclasses which implement the Inside-Out technique + +=head1 SYNOPSIS + + package Foo; + + sub meta { InsideOutClass->initialize($_[0]) } + + __PACKAGE__->meta->add_attribute( + InsideOutClass::Attribute->new('foo' => ( + reader => 'get_foo', + writer => 'set_foo' + )) + ); + + sub new { + my $class = shift; + bless $class->meta->construct_instance() => $class; + } + + # now you can just use the class as normal + +=head1 DESCRIPTION + +This is a set of example metaclasses which implement the Inside-Out +class technique. What follows is a brief explaination of the code +found in this module. + +First step is to subclass B and override the +C method. The default C +will create a HASH reference using the parameters and attribute +default values. Since inside-out objects don't use HASH refs, and +use package variables instead, we need to write code to handle +this difference. + +The next step is to create the subclass of B +and override the method generation code. This requires overloading +C, C, +C and C. All +other aspects are taken care of with the existing B +infastructure. + +And that is pretty much all. Of course I am ignoring need for +inside-out objects to be C-ed, and some other details as +well, but this is an example. A real implementation is left as an +exercise to the reader. + +=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/InstanceCountingClass.pm b/examples/InstanceCountingClass.pod similarity index 95% rename from examples/InstanceCountingClass.pm rename to examples/InstanceCountingClass.pod index fdfb76d..93ba4d5 100644 --- a/examples/InstanceCountingClass.pm +++ b/examples/InstanceCountingClass.pod @@ -1,5 +1,6 @@ -package InstanceCountingClass; +package # hide the package from PAUSE + InstanceCountingClass; use strict; use warnings; diff --git a/examples/Perl6Attribute.pm b/examples/Perl6Attribute.pod similarity index 93% rename from examples/Perl6Attribute.pm rename to examples/Perl6Attribute.pod index 5ba274e..47c93f9 100644 --- a/examples/Perl6Attribute.pm +++ b/examples/Perl6Attribute.pod @@ -1,5 +1,6 @@ -package Perl6Attribute; +package # hide the package from PAUSE + Perl6Attribute; use strict; use warnings; @@ -32,7 +33,7 @@ __END__ =head1 NAME -Perl6Attribute - An attribute metaclass for Perl 6 style attributes +Perl6Attribute - An example attribute metaclass for Perl 6 style attributes =head1 SYNOPSIS diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index d26344c..e968bae 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -5,9 +5,9 @@ use strict; use warnings; use Carp 'confess'; -use Scalar::Util 'blessed', 'reftype'; +use Scalar::Util 'blessed', 'reftype', 'weaken'; -our $VERSION = '0.01'; +our $VERSION = '0.02'; sub meta { require Class::MOP::Class; @@ -41,7 +41,10 @@ sub new { writer => $options{writer}, predicate => $options{predicate}, init_arg => $options{init_arg}, - default => $options{default} + default => $options{default}, + # keep a weakened link to the + # class we are associated with + associated_class => undef, } => $class; } @@ -72,61 +75,90 @@ sub default { $self->{default}; } -{ - # this is just a utility routine to - # handle the details of accessors - my $_inspect_accessor = sub { - my ($attr_name, $type, $accessor) = @_; - - my %ACCESSOR_TEMPLATES = ( - 'accessor' => qq{sub { - \$_[0]->{'$attr_name'} = \$_[1] if scalar(\@_) == 2; - \$_[0]->{'$attr_name'}; - }}, - 'reader' => qq{sub { - \$_[0]->{'$attr_name'}; - }}, - 'writer' => qq{sub { - \$_[0]->{'$attr_name'} = \$_[1]; - }}, - 'predicate' => qq{sub { - defined \$_[0]->{'$attr_name'} ? 1 : 0; - }} - ); - - if (reftype($accessor) && reftype($accessor) eq 'HASH') { - my ($name, $method) = each %{$accessor}; - return ($name, Class::MOP::Attribute::Accessor->wrap($method)); - } - else { - my $method = eval $ACCESSOR_TEMPLATES{$type}; - confess "Could not create the $type for $attr_name CODE(\n" . $ACCESSOR_TEMPLATES{$type} . "\n) : $@" if $@; - return ($accessor => Class::MOP::Attribute::Accessor->wrap($method)); - } - }; +# class association - sub install_accessors { - my ($self, $class) = @_; - (blessed($class) && $class->isa('Class::MOP::Class')) - || confess "You must pass a Class::MOP::Class instance (or a subclass)"; - $class->add_method( - $_inspect_accessor->($self->name, 'accessor' => $self->accessor()) - ) if $self->has_accessor(); - - $class->add_method( - $_inspect_accessor->($self->name, 'reader' => $self->reader()) - ) if $self->has_reader(); - - $class->add_method( - $_inspect_accessor->($self->name, 'writer' => $self->writer()) - ) if $self->has_writer(); - - $class->add_method( - $_inspect_accessor->($self->name, 'predicate' => $self->predicate()) - ) if $self->has_predicate(); - return; +sub associated_class { $_[0]->{associated_class} } + +sub attach_to_class { + my ($self, $class) = @_; + (blessed($class) && $class->isa('Class::MOP::Class')) + || confess "You must pass a Class::MOP::Class instance (or a subclass)"; + weaken($self->{associated_class} = $class); +} + +sub detach_from_class { + my $self = shift; + $self->{associated_class} = undef; +} + +## Method generation helpers + +sub generate_accessor_method { + my ($self, $attr_name) = @_; + eval qq{sub { + \$_[0]->{'$attr_name'} = \$_[1] if scalar(\@_) == 2; + \$_[0]->{'$attr_name'}; + }}; +} + +sub generate_reader_method { + my ($self, $attr_name) = @_; + eval qq{sub { + \$_[0]->{'$attr_name'}; + }}; +} + +sub generate_writer_method { + my ($self, $attr_name) = @_; + eval qq{sub { + \$_[0]->{'$attr_name'} = \$_[1]; + }}; +} + +sub generate_predicate_method { + my ($self, $attr_name) = @_; + eval qq{sub { + defined \$_[0]->{'$attr_name'} ? 1 : 0; + }}; +} + +sub process_accessors { + my ($self, $type, $accessor) = @_; + if (reftype($accessor) && reftype($accessor) eq 'HASH') { + my ($name, $method) = each %{$accessor}; + return ($name, Class::MOP::Attribute::Accessor->wrap($method)); } + else { + my $generator = $self->can('generate_' . $type . '_method'); + ($generator) + || confess "There is no method generator for the type='$type'"; + if (my $method = $self->$generator($self->name)) { + return ($accessor => Class::MOP::Attribute::Accessor->wrap($method)); + } + confess "Could not create the methods for " . $self->name . " because : $@"; + } +} + +sub install_accessors { + my $self = shift; + my $class = $self->associated_class; + $class->add_method( + $self->process_accessors('accessor' => $self->accessor()) + ) if $self->has_accessor(); + + $class->add_method( + $self->process_accessors('reader' => $self->reader()) + ) if $self->has_reader(); + + $class->add_method( + $self->process_accessors('writer' => $self->writer()) + ) if $self->has_writer(); + + $class->add_method( + $self->process_accessors('predicate' => $self->predicate()) + ) if $self->has_predicate(); + return; } { @@ -141,13 +173,11 @@ sub default { }; sub remove_accessors { - my ($self, $class) = @_; - (blessed($class) && $class->isa('Class::MOP::Class')) - || confess "You must pass a Class::MOP::Class instance (or a subclass)"; - $_remove_accessor->($self->accessor(), $class) if $self->has_accessor(); - $_remove_accessor->($self->reader(), $class) if $self->has_reader(); - $_remove_accessor->($self->writer(), $class) if $self->has_writer(); - $_remove_accessor->($self->predicate(), $class) if $self->has_predicate(); + my $self = shift; + $_remove_accessor->($self->accessor(), $self->associated_class()) if $self->has_accessor(); + $_remove_accessor->($self->reader(), $self->associated_class()) if $self->has_reader(); + $_remove_accessor->($self->writer(), $self->associated_class()) if $self->has_writer(); + $_remove_accessor->($self->predicate(), $self->associated_class()) if $self->has_predicate(); return; } @@ -371,17 +401,52 @@ These are all basic predicate methods for the values passed into C. =back +=head2 Class association + +=over 4 + +=item B + +=item B + +=item B + +=back + =head2 Attribute Accessor generation =over 4 -=item B +=item B This allows the attribute to generate and install code for it's own I methods. This is called by C. -=item B +This method will call C for each of the possible +method types (accessor, reader, writer & predicate). + +=item B + +This takes a C<$type> (accessor, reader, writer or predicate), and +a C<$value> (the value passed into the constructor for each of the +different types). It will then either generate the method itself +(using the C methods listed below) or it will +use the custom method passed through the constructor. + +=over 4 + +=item B + +=item B + +=item B + +=item B + +=back + +=item B This allows the attribute to remove the method for it's own I. This is called by @@ -418,4 +483,4 @@ L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -=cut +=cut \ No newline at end of file diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index d70f2c9..7e9832f 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -270,7 +270,8 @@ sub add_attribute { my ($self,$attribute) = @_; (blessed($attribute) && $attribute->isa('Class::MOP::Attribute')) || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)"; - $attribute->install_accessors($self); + $attribute->attach_to_class($self); + $attribute->install_accessors(); $self->{'%:attrs'}->{$attribute->name} = $attribute; } @@ -295,8 +296,9 @@ sub remove_attribute { || confess "You must define an attribute name"; my $removed_attribute = $self->{'%:attrs'}->{$attribute_name}; delete $self->{'%:attrs'}->{$attribute_name} - if defined $removed_attribute; - $removed_attribute->remove_accessors($self); + if defined $removed_attribute; + $removed_attribute->remove_accessors(); + $removed_attribute->detach_from_class(); return $removed_attribute; } diff --git a/t/101_InstanceCountingClass_test.t b/t/101_InstanceCountingClass_test.t index e47ab1b..9f2215f 100644 --- a/t/101_InstanceCountingClass_test.t +++ b/t/101_InstanceCountingClass_test.t @@ -4,10 +4,11 @@ use strict; use warnings; use Test::More tests => 12; +use File::Spec; BEGIN { use_ok('Class::MOP'); - use_ok('examples::InstanceCountingClass'); + require_ok(File::Spec->catdir('examples', 'InstanceCountingClass.pod')); } =pod diff --git a/t/102_InsideOutClass_test.t b/t/102_InsideOutClass_test.t index dd09101..a8cd234 100644 --- a/t/102_InsideOutClass_test.t +++ b/t/102_InsideOutClass_test.t @@ -4,10 +4,11 @@ use strict; use warnings; use Test::More tests => 19; +use File::Spec; BEGIN { use_ok('Class::MOP'); - use_ok('examples::InsideOutClass'); + require_ok(File::Spec->catdir('examples', 'InsideOutClass.pod')); } { diff --git a/t/103_Perl6Attribute_test.t b/t/103_Perl6Attribute_test.t index 6dd8976..90772f0 100644 --- a/t/103_Perl6Attribute_test.t +++ b/t/103_Perl6Attribute_test.t @@ -4,10 +4,11 @@ use strict; use warnings; use Test::More tests => 10; +use File::Spec; BEGIN { use_ok('Class::MOP'); - use_ok('examples::Perl6Attribute'); + require_ok(File::Spec->catdir('examples', 'Perl6Attribute.pod')); } {