build_requires => {
'Test::More' => '0.47',
'Test::Exception' => '0.21',
+ 'File::Spec' => 0,
},
create_makefile_pl => 'traditional',
recursive_test_files => 1,
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
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
+++ /dev/null
-
-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<Class::MOP::Class> and override the
-C<construct_instance> method. The default C<construct_instance>
-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<Class::MOP::Attribute>
-and override the C<install_accessors> method (you would also need to
-override the C<remove_accessors> too, but we can safely ignore that
-in our example). The C<install_accessor> method is called by the
-C<add_attribute> method of B<Class::MOP::Class>, 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<DESTROY>-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 E<lt>stevan@iinteractive.comE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2006 by Infinity Interactive, Inc.
-
-L<http://www.iinteractive.com>
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
--- /dev/null
+
+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<Class::MOP::Class> and override the
+C<construct_instance> method. The default C<construct_instance>
+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<Class::MOP::Attribute>
+and override the method generation code. This requires overloading
+C<generate_accessor_method>, C<generate_reader_method>,
+C<generate_writer_method> and C<generate_predicate_method>. All
+other aspects are taken care of with the existing B<Class::MOP::Attribute>
+infastructure.
+
+And that is pretty much all. Of course I am ignoring need for
+inside-out objects to be C<DESTROY>-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 E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
-package InstanceCountingClass;
+package # hide the package from PAUSE
+ InstanceCountingClass;
use strict;
use warnings;
-package Perl6Attribute;
+package # hide the package from PAUSE
+ Perl6Attribute;
use strict;
use warnings;
=head1 NAME
-Perl6Attribute - An attribute metaclass for Perl 6 style attributes
+Perl6Attribute - An example attribute metaclass for Perl 6 style attributes
=head1 SYNOPSIS
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;
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;
}
$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;
}
{
};
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;
}
=back
+=head2 Class association
+
+=over 4
+
+=item B<associated_class>
+
+=item B<attach_to_class ($class)>
+
+=item B<detach_from_class>
+
+=back
+
=head2 Attribute Accessor generation
=over 4
-=item B<install_accessors ($class)>
+=item B<install_accessors>
This allows the attribute to generate and install code for it's own
I<accessor/reader/writer/predicate> methods. This is called by
C<Class::MOP::Class::add_attribute>.
-=item B<remove_accessors ($class)>
+This method will call C<process_accessors> for each of the possible
+method types (accessor, reader, writer & predicate).
+
+=item B<process_accessors ($type, $value)>
+
+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<generate_*_method> methods listed below) or it will
+use the custom method passed through the constructor.
+
+=over 4
+
+=item B<generate_accessor_method ($attr_name)>
+
+=item B<generate_predicate_method ($attr_name)>
+
+=item B<generate_reader_method ($attr_name)>
+
+=item B<generate_writer_method ($attr_name)>
+
+=back
+
+=item B<remove_accessors>
This allows the attribute to remove the method for it's own
I<accessor/reader/writer/predicate>. This is called by
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
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;
}
|| 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;
}
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
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'));
}
{
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'));
}
{
projects / gitmo/Class-MOP.git / commitdiff