use Scalar::Util 'blessed';
+use Class::MOP::Class;
+use Class::MOP::Attribute;
+use Class::MOP::Method;
+
our $VERSION = '0.01';
-# my %METAS;
-# sub UNIVERSAL::meta {
-# my $class = blessed($_[0]) || $_[0];
-# $METAS{$class} ||= Class::MOP::Class->initialize($class)
-# }
+sub import {
+ shift;
+ return unless @_;
+ if ($_[0] eq ':universal') {
+ *UNIVERSAL::meta = sub {
+ Class::MOP::Class->initialize(blessed($_[0]) || $_[0])
+ };
+ }
+}
1;
=head1 SYNOPSIS
- # ... coming soon
+ use Class::MOP ':universal';
+
+ package Foo;
+
+ Foo->meta->add_method('foo' => sub { ... });
=head1 DESCRIPTON
=head2 What changes do I have to make to use this module?
-This module was designed to be as unintrusive as possible. So many of
+This module was designed to be as unintrusive as possible. Many of
it's features are accessible without B<any> change to your existsing
code at all. It is meant to be a compliment to your existing code and
-not an intrusion on your code base.
+not an intrusion on your code base. Unlike many other B<Class::>
+modules, this module does require you subclass it, or even that you
+C<use> it in within your module's package.
-The only feature which requires additions to your code are the
-attribute handling and instance construction features. The only reason
-for this is because Perl 5's object system does not actually have
-these features built in. More information about this feature can be
-found below.
+The only features which requires additions to your code are the
+attribute handling and instance construction features, and these are
+both optional features as well. The only reason for this is because
+Perl 5's object system does not actually have these features built
+in. More information about this feature can be found below.
=head2 A Note about Performance?
and so performance is tuned for it.
This library in particular does it's absolute best to avoid putting
-B<any> drain at all upon your code's performance, while still trying
-to make sure it is fast as well (although only as a secondary
-concern).
+B<any> drain at all upon your code's performance. In fact, by itself
+it does nothing to affect your existing code. So you only pay for
+what you actually use.
=head1 PROTOCOLS
use strict;
use warnings;
-use Carp 'confess';
+use Carp 'confess';
+use Scalar::Util 'blessed';
+
+use Class::MOP::Class;
+use Class::MOP::Method;
our $VERSION = '0.01';
+sub meta { Class::MOP::Class->initialize($_[0]) }
+
sub new {
my $class = shift;
my $name = shift;
(defined $name && $name ne '')
|| confess "You must provide a name for the attribute";
-
+ (!exists $options{reader} && !exists $options{writer})
+ || confess "You cannot declare an accessor and reader and/or writer functions"
+ if exists $options{accessor};
+
bless {
name => $name,
accessor => $options{accessor},
sub has_default { (shift)->{default} ? 1 : 0 }
sub default { (shift)->{default} }
-sub generate_accessor {
- my $self = shift;
- # ...
+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)";
+
+ if ($self->has_accessor()) {
+ $class->add_method($self->accessor() => Class::MOP::Attribute::Accessor->wrap(sub {
+ $_[0]->{$self->name} = $_[1] if scalar(@_) == 2;
+ $_[0]->{$self->name};
+ }));
+ }
+ else {
+ if ($self->has_reader()) {
+ $class->add_method($self->reader() => Class::MOP::Attribute::Accessor->wrap(sub {
+ $_[0]->{$self->name};
+ }));
+ }
+ if ($self->has_writer()) {
+ $class->add_method($self->writer() => Class::MOP::Attribute::Accessor->wrap(sub {
+ $_[0]->{$self->name} = $_[1];
+ 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)";
+
+ if ($self->has_accessor()) {
+ my $method = $class->get_method($self->accessor);
+ $class->remove_method($self->accessor)
+ if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
+ }
+ else {
+ if ($self->has_reader()) {
+ my $method = $class->get_method($self->reader);
+ $class->remove_method($self->reader)
+ if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
+ }
+ if ($self->has_writer()) {
+ my $method = $class->get_method($self->writer);
+ $class->remove_method($self->writer)
+ if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
+ }
+ }
}
+package Class::MOP::Attribute::Accessor;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+our @ISA = ('Class::MOP::Method');
+
1;
__END__
=over 4
-=item B<generate_accessor>
+=item B<install_accessors ($class)>
+
+This allows the attribute to generate and install code for it's own
+accessor methods. This is called by C<Class::MOP::Class::add_attribute>.
+
+=item B<remove_accessors ($class)>
+
+This allows the attribute to remove the method for it's own
+accessor. This is called by C<Class::MOP::Class::remove_attribute>.
+
+=back
+
+=head2 Introspection
+
+=over 4
-This allows the attribute to generate code for it's own accessor
-methods. This is mostly part of an internal protocol between the class
-and it's own attributes, see the C<create_all_accessors> method above.
+=item B<meta>
=back
our $VERSION = '0.01';
+# Self-introspection
+
+sub meta { $_[0]->initialize($_[0]) }
+
# Creation
{
my $meta = $class->initialize($package_name);
$meta->superclasses(@{$options{superclasses}})
if exists $options{superclasses};
+ # NOTE:
+ # process attributes first, so that they can
+ # install accessors, but locally defined methods
+ # can then overwrite them. It is maybe a little odd, but
+ # I think this should be the order of things.
+ if (exists $options{attributes}) {
+ foreach my $attr_name (keys %{$options{attributes}}) {
+ $meta->add_attribute($attr_name, $options{attributes}->{$attr_name});
+ }
+ }
if (exists $options{methods}) {
foreach my $method_name (keys %{$options{methods}}) {
$meta->add_method($method_name, $options{methods}->{$method_name});
}
- }
+ }
return $meta;
}
{
## private utility functions for has_method
- my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } };
- my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } };
+ my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' };
+ my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } || '' };
sub has_method {
my ($self, $method_name) = @_;
## Attributes
sub add_attribute {
- my ($self, $attribute_name, $attribute) = @_;
- (defined $attribute_name && $attribute_name)
- || confess "You must define an attribute name";
+ my ($self,$attribute) = @_;
(blessed($attribute) && $attribute->isa('Class::MOP::Attribute'))
|| confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
- $self->{'%:attrs'}->{$attribute_name} = $attribute;
+ $attribute->install_accessors($self);
+ $self->{'%:attrs'}->{$attribute->name} = $attribute;
}
sub has_attribute {
my $removed_attribute = $self->{'%:attrs'}->{$attribute_name};
delete $self->{'%:attrs'}->{$attribute_name}
if defined $removed_attribute;
+ $removed_attribute->remove_accessors($self);
return $removed_attribute;
}
}
return @attrs;
}
-
-sub create_all_accessors {
-
-}
+
1;
=head1 METHODS
+=head2 Self Introspection
+
+=over 4
+
+=item B<meta>
+
+This allows Class::MOP::Class to actually introspect itself.
+
+=back
+
=head2 Class construction
These methods handle creating Class objects, which can be used to
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
-
-=item B<create_all_accessors>
-
-This will communicate with all of the classes attributes to create
-and install the appropriate accessors. (see L<The Attribute Protocol>
-below for more details).
+attribute meta-object.
=back
use strict;
use warnings;
+use Carp 'confess';
+use Scalar::Util 'reftype';
+
+use Class::MOP::Class;
+
our $VERSION = '0.01';
+
+sub meta { Class::MOP::Class->initialize($_[0]) }
+
+sub wrap {
+ my $class = shift;
+ my $code = shift;
+
+ (reftype($code) && reftype($code) eq 'CODE')
+ || confess "You must supply a CODE reference to wrap";
+
+ bless $code => $class;
+}
1;
bless the subroutine and provide some very simple introspection
methods for it.
+=head1 METHODS
+
+=over 4
+
+=item B<wrap (&code)>
+
+=item B<meta>
+
+=back
+
=head1 AUTHOR
Stevan Little E<gt>stevan@iinteractive.comE<lt>
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP', ':universal');
+}
+
+my $FOO_ATTR = Class::MOP::Attribute->new('$foo');
+my $BAR_ATTR = Class::MOP::Attribute->new('$bar' => (
+ accessor => 'bar'
+));
+my $BAZ_ATTR = Class::MOP::Attribute->new('$baz' => (
+ reader => 'get_baz',
+ writer => 'set_baz',
+));
+
+{
+ package Foo;
+
+ my $meta = __PACKAGE__->meta;
+ ::lives_ok {
+ $meta->add_attribute($FOO_ATTR);
+ } '... we added an attribute to Foo successfully';
+ ::ok($meta->has_attribute('$foo'), '... Foo has $foo attribute');
+ ::is($meta->get_attribute('$foo'), $FOO_ATTR, '... got the right attribute back for Foo');
+
+ ::ok(!$meta->has_method('foo'), '... no accessor created');
+}
+{
+ package Bar;
+ our @ISA = ('Foo');
+
+ my $meta = __PACKAGE__->meta;
+ ::lives_ok {
+ $meta->add_attribute($BAR_ATTR);
+ } '... we added an attribute to Bar successfully';
+ ::ok($meta->has_attribute('$bar'), '... Bar has $bar attribute');
+ ::is($meta->get_attribute('$bar'), $BAR_ATTR, '... got the right attribute back for Bar');
+
+ ::ok($meta->has_method('bar'), '... an accessor has been created');
+ ::isa_ok($meta->get_method('bar'), 'Class::MOP::Attribute::Accessor');
+}
+{
+ package Baz;
+ our @ISA = ('Bar');
+
+ my $meta = __PACKAGE__->meta;
+ ::lives_ok {
+ $meta->add_attribute($BAZ_ATTR);
+ } '... we added an attribute to Baz successfully';
+ ::ok($meta->has_attribute('$baz'), '... Baz has $baz attribute');
+ ::is($meta->get_attribute('$baz'), $BAZ_ATTR, '... got the right attribute back for Baz');
+
+ ::ok($meta->has_method('get_baz'), '... a reader has been created');
+ ::ok($meta->has_method('set_baz'), '... a writer has been created');
+
+ ::isa_ok($meta->get_method('get_baz'), 'Class::MOP::Attribute::Accessor');
+ ::isa_ok($meta->get_method('set_baz'), 'Class::MOP::Attribute::Accessor');
+}
+
+{
+ my $meta = Baz->meta;
+ isa_ok($meta, 'Class::MOP::Class');
+
+ is_deeply(
+ [ 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
+ },
+ ],
+ '... got the right list of applicable attributes for Baz');
+}
+
+
use_ok('Class::MOP::Class');
}
-my $meta = Class::MOP::Class->initialize('Class::MOP::Class');
+my $meta = Class::MOP::Class->meta();
isa_ok($meta, 'Class::MOP::Class');
foreach my $method_name (qw(
+ meta
+
initialize create
name version
get_method_list compute_all_applicable_methods find_all_methods_by_name
has_attribute get_attribute add_attribute remove_attribute
- get_attribute_list compute_all_applicable_attributes create_all_accessors
+ get_attribute_list compute_all_applicable_attributes
)) {
ok($meta->has_method($method_name), '... Class::MOP::Class->has_method(' . $method_name . ')');
{
}
}
+foreach my $non_method_name (qw(
+ confess
+ blessed reftype
+ subname
+ svref_2object
+ )) {
+ ok(!$meta->has_method($non_method_name), '... NOT Class::MOP::Class->has_method(' . $non_method_name . ')');
+}
+
is($meta->name, 'Class::MOP::Class', '... Class::MOP::Class->name');
is($meta->version, $Class::MOP::Class::VERSION, '... Class::MOP::Class->version');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP::Attribute');
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$foo');
+ isa_ok($attr, 'Class::MOP::Attribute');
+
+ is($attr->name, '$foo', '... $attr->name == $foo');
+
+ ok(!$attr->has_accessor, '... $attr does not have an accessor');
+ ok(!$attr->has_reader, '... $attr does not have an reader');
+ ok(!$attr->has_writer, '... $attr does not have an writer');
+ ok(!$attr->has_init_arg, '... $attr does not have an init_arg');
+ ok(!$attr->has_default, '... $attr does not have an default');
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$foo', (
+ init_arg => '-foo',
+ default => 'BAR'
+ ));
+ isa_ok($attr, 'Class::MOP::Attribute');
+
+ is($attr->name, '$foo', '... $attr->name == $foo');
+
+ ok($attr->has_init_arg, '... $attr does have an init_arg');
+ is($attr->init_arg, '-foo', '... $attr->init_arg == -foo');
+ ok($attr->has_default, '... $attr does have an default');
+ is($attr->default, 'BAR', '... $attr->default == BAR');
+
+ ok(!$attr->has_accessor, '... $attr does not have an accessor');
+ ok(!$attr->has_reader, '... $attr does not have an reader');
+ ok(!$attr->has_writer, '... $attr does not have an writer');
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$foo', (
+ accessor => 'foo',
+ init_arg => '-foo',
+ default => 'BAR'
+ ));
+ isa_ok($attr, 'Class::MOP::Attribute');
+
+ is($attr->name, '$foo', '... $attr->name == $foo');
+
+ ok($attr->has_init_arg, '... $attr does have an init_arg');
+ is($attr->init_arg, '-foo', '... $attr->init_arg == -foo');
+ ok($attr->has_default, '... $attr does have an default');
+ is($attr->default, 'BAR', '... $attr->default == BAR');
+
+ ok($attr->has_accessor, '... $attr does have an accessor');
+ is($attr->accessor, 'foo', '... $attr->accessor == foo');
+
+ ok(!$attr->has_reader, '... $attr does not have an reader');
+ ok(!$attr->has_writer, '... $attr does not have an writer');
+}
+
+{
+ my $attr = Class::MOP::Attribute->new('$foo', (
+ reader => 'get_foo',
+ writer => 'set_foo',
+ init_arg => '-foo',
+ default => 'BAR'
+ ));
+ isa_ok($attr, 'Class::MOP::Attribute');
+
+ is($attr->name, '$foo', '... $attr->name == $foo');
+
+ ok($attr->has_init_arg, '... $attr does have an init_arg');
+ is($attr->init_arg, '-foo', '... $attr->init_arg == -foo');
+ ok($attr->has_default, '... $attr does have an default');
+ is($attr->default, 'BAR', '... $attr->default == BAR');
+
+ ok($attr->has_reader, '... $attr does have an reader');
+ is($attr->reader, 'get_foo', '... $attr->reader == get_foo');
+ ok($attr->has_writer, '... $attr does have an writer');
+ is($attr->writer, 'set_foo', '... $attr->writer == set_foo');
+
+ ok(!$attr->has_accessor, '... $attr does not have an accessor');
+}
+
+dies_ok {
+ my $attr = Class::MOP::Attribute->new('$foo', (
+ accessor => 'foo',
+ reader => 'get_foo',
+ ));
+} '... cannot create accessors with reader/writers';
+
+dies_ok {
+ my $attr = Class::MOP::Attribute->new('$foo', (
+ accessor => 'foo',
+ writer => 'set_foo',
+ ));
+} '... cannot create accessors with reader/writers';
+
+dies_ok {
+ my $attr = Class::MOP::Attribute->new('$foo', (
+ accessor => 'foo',
+ reader => 'get_foo',
+ writer => 'set_foo',
+ ));
+} '... cannot create accessors with reader/writers';
+
+
+{
+ my $meta = Class::MOP::Attribute->meta();
+ isa_ok($meta, 'Class::MOP::Class');
+
+ foreach my $method_name (qw(
+ meta
+ new
+ has_accessor accessor
+ has_writer writer
+ has_reader reader
+ has_init_arg init_arg
+ has_default default
+ install_accessors
+ remove_accessors
+ )) {
+ ok($meta->has_method($method_name), '... Class::MOP::Attribute->has_method(' . $method_name . ')');
+ }
+
+
+}
projects / gitmo/Class-MOP.git / commitdiff