use Class::MOP 'meta';
-use Scalar::Util 'refaddr';
+our $VERSION = '0.02';
-our $VERSION = '0.01';
+use Scalar::Util 'refaddr';
-__PACKAGE__->meta->superclasses('Class::MOP::Class');
+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,
return $instance;
}
-
-package InsideOutAttribute;
+package InsideOutClass::Attribute;
use strict;
use warnings;
-use Carp 'confess';
-use Scalar::Util 'blessed', 'reftype', 'refaddr';
-
use Class::MOP 'meta';
-our $VERSION = '0.01';
+our $VERSION = '0.02';
-__PACKAGE__->meta->superclasses('Class::MOP::Attribute');
+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 ($attr_name, $type, $accessor) = @_;
my %ACCESSOR_TEMPLATES = (
'accessor' => 'sub {
$' . $attr_name . '{ refaddr($_[0]) } = $_[1] if scalar(@_) == 2;
}'
);
- 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));
- }
+ 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 {
(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())
## &remove_attribute is left as an exercise for the reader :)
-1;
\ No newline at end of file
+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
our $VERSION = '0.01';
-__PACKAGE__->meta->superclasses('Class::MOP::Class');
+use base 'Class::MOP::Class';
__PACKAGE__->meta->add_attribute(
Class::MOP::Attribute->new('$:count' => (
return $class->SUPER::construct_instance();
}
-1;
\ No newline at end of file
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+InstanceCountingClass - An example metaclass which counts instances
+
+=head1 SYNOPSIS
+
+ package Foo;
+
+ sub meta { InstanceCountingClass->initialize($_[0]) }
+ sub new {
+ my $class = shift;
+ bless $class->meta->construct_instance() => $class;
+ }
+
+ # ... meanwhile, somewhere in the code
+
+ my $foo = Foo->new();
+ print Foo->meta->get_count(); # prints 1
+
+ my $foo2 = Foo->new();
+ print Foo->meta->get_count(); # prints 2
+
+ # ... etc etc etc
+
+=head1 DESCRIPTION
+
+This is a classic example of a metaclass which keeps a count of each
+instance which is created.
+
+=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 Perl6Attribute;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use base 'Class::MOP::Attribute';
+
+sub new {
+ my ($class, $attribute_name, %options) = @_;
+
+ # extract the sigil and accessor name
+ my ($sigil, $accessor_name) = ($attribute_name =~ /^([\$\@\%])\.(.*)$/);
+
+ # pass the accessor name
+ $options{accessor} = $accessor_name;
+
+ # create a default value based on the sigil
+ $options{default} = sub { [] } if ($sigil eq '@');
+ $options{default} = sub { {} } if ($sigil eq '%');
+
+ $class->SUPER::new($attribute_name, %options);
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Perl6Attribute - An attribute metaclass for Perl 6 style attributes
+
+=head1 SYNOPSIS
+
+ package Foo;
+
+ use Class::MOP 'meta';
+
+ Foo->meta->add_attribute(Perl6Attribute->new('$.foo'));
+ Foo->meta->add_attribute(Perl6Attribute->new('@.bar'));
+ Foo->meta->add_attribute(Perl6Attribute->new('%.baz'));
+
+ sub new {
+ my $class = shift;
+ bless $class->meta->construct_instance() => $class;
+ }
+
+=head1 DESCRIPTION
+
+This is an attribute metaclass which implements Perl 6 style
+attributes, including the auto-generating accessors.
+
+This code is very simple, we only need to subclass
+C<Class::MOP::Attribute> and override C<&new>. Then we just
+pre-process the attribute name, and create the accessor name
+and default value based on it.
+
+More advanced features like the C<handles> trait (see
+L<Perl6::Bible/A12>) can be accomplished as well doing the
+same pre-processing approach. This is left as an exercise to
+the reader though (if you do it, please send me a patch
+though, and will update this).
+
+=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
\ No newline at end of file
projects / gitmo/Class-MOP.git / commitdiff