use warnings;
use Scalar::Util 'blessed';
+use Carp 'confess';
use Class::MOP::Class;
use Class::MOP::Attribute;
}
}
+## Bootstrapping
+
+# We need to add in the meta-attributes here so that
+# any subclass of Class::MOP::* will be able to
+# inherit them using &construct_instance
+
+## Class::MOP::Class
+
+Class::MOP::Class->meta->add_attribute(
+ Class::MOP::Attribute->new('$:pkg' => (
+ init_arg => ':pkg'
+ ))
+);
+
+Class::MOP::Class->meta->add_attribute(
+ Class::MOP::Attribute->new('%:attrs' => (
+ init_arg => ':attrs',
+ default => sub { {} }
+ ))
+);
+
+## Class::MOP::Attribute
+
+Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('name'));
+Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('accessor'));
+Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('reader'));
+Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('writer'));
+Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('predicate'));
+Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('init_arg'));
+Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('default'));
+
+# NOTE: (meta-circularity)
+# This should be one of the last things done
+# it will "tie the knot" with Class::MOP::Attribute
+# so that it uses the attributes meta-objects
+# to construct itself.
+Class::MOP::Attribute->meta->add_method('new' => sub {
+ my $class = shift;
+ my $name = shift;
+ my %options = @_;
+
+ (defined $name && $name)
+ || 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 $class->meta->construct_instance(name => $name, %options) => $class;
+});
+
+# NOTE: (meta-circularity)
+# This is how we "tie the knot" for the class
+# meta-objects. This is used to construct the
+# Class::MOP::Class instances after all the
+# bootstrapping is complete.
+Class::MOP::Class->meta->add_method('construct_class_instance' => sub {
+ my ($class, $package_name) = @_;
+ (defined $package_name && $package_name)
+ || confess "You must pass a package name";
+ bless Class::MOP::Class->meta->construct_instance(':pkg' => $package_name) => blessed($class) || $class
+});
+
1;
__END__
use Carp 'confess';
use Scalar::Util 'blessed', 'reftype';
-use Class::MOP::Class;
-use Class::MOP::Method;
-
our $VERSION = '0.01';
-sub meta { Class::MOP::Class->initialize($_[0]) }
+sub meta {
+ require Class::MOP::Class;
+ Class::MOP::Class->initialize($_[0])
+}
+# NOTE: (meta-circularity)
+# This method will be replaces in the
+# boostrap section of Class::MOP, by
+# a new version which uses the
+# &Class::MOP::Class::construct_instance
+# method to build an attribute meta-object
+# which itself is described with attribute
+# meta-objects.
+# - Ain't meta-circularity grand? :)
sub new {
my $class = shift;
my $name = shift;
sub name { $_[0]->{name} }
-sub has_accessor { defined($_[0]->{accessor}) ? 1 : 0 }
-sub has_reader { defined($_[0]->{reader}) ? 1 : 0 }
-sub has_writer { defined($_[0]->{writer}) ? 1 : 0 }
+sub has_accessor { defined($_[0]->{accessor}) ? 1 : 0 }
+sub has_reader { defined($_[0]->{reader}) ? 1 : 0 }
+sub has_writer { defined($_[0]->{writer}) ? 1 : 0 }
sub has_predicate { defined($_[0]->{predicate}) ? 1 : 0 }
-sub has_init_arg { defined($_[0]->{init_arg}) ? 1 : 0 }
-sub has_default { defined($_[0]->{default}) ? 1 : 0 }
+sub has_init_arg { defined($_[0]->{init_arg}) ? 1 : 0 }
+sub has_default { defined($_[0]->{default}) ? 1 : 0 }
sub accessor { $_[0]->{accessor} }
sub reader { $_[0]->{reader} }
sub default {
my $self = shift;
if (reftype($self->{default}) && reftype($self->{default}) eq 'CODE') {
+ # if the default is a CODE ref, then
+ # we pass in the instance and default
+ # can return a value based on that
+ # instance. Somewhat crude, but works.
return $self->{default}->(shift);
}
$self->{default};
}
-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()) {
- my $accessor = $self->accessor();
+{
+ # 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 {
+ $_[0]->{$attr_name} = $_[1] if scalar(@_) == 2;
+ $_[0]->{$attr_name};
+ },
+ 'reader' => sub {
+ $_[0]->{$attr_name};
+ },
+ 'writer' => sub {
+ $_[0]->{$attr_name} = $_[1];
+ return;
+ },
+ 'predicate' => sub {
+ return defined $_[0]->{$attr_name} ? 1 : 0;
+ }
+ );
+
if (reftype($accessor) && reftype($accessor) eq 'HASH') {
my ($name, $method) = each %{$accessor};
- $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method));
+ return ($name, Class::MOP::Attribute::Accessor->wrap($method));
}
else {
- $class->add_method($accessor => Class::MOP::Attribute::Accessor->wrap(sub {
- $_[0]->{$self->name} = $_[1] if scalar(@_) == 2;
- $_[0]->{$self->name};
- }));
- }
- }
- else {
- if ($self->has_reader()) {
- my $reader = $self->reader();
- if (reftype($reader) && reftype($reader) eq 'HASH') {
- my ($name, $method) = each %{$reader};
- $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method));
- }
- else {
- $class->add_method($reader => Class::MOP::Attribute::Accessor->wrap(sub {
- $_[0]->{$self->name};
- }));
- }
- }
- if ($self->has_writer()) {
- my $writer = $self->writer();
- if (reftype($writer) && reftype($writer) eq 'HASH') {
- my ($name, $method) = each %{$writer};
- $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method));
- }
- else {
- $class->add_method($writer => Class::MOP::Attribute::Accessor->wrap(sub {
- $_[0]->{$self->name} = $_[1];
- return;
- }));
- }
- }
+ return ($accessor => Class::MOP::Attribute::Accessor->wrap($ACCESSOR_TEMPLATES{$type}));
+ }
+ };
+
+ 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();
}
- if ($self->has_predicate()) {
- my $predicate = $self->predicate();
- if (reftype($predicate) && reftype($predicate) eq 'HASH') {
- my ($name, $method) = each %{$predicate};
- $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method));
- }
- else {
- $class->add_method($predicate => Class::MOP::Attribute::Accessor->wrap(sub {
- defined $_[0]->{$self->name} ? 1 : 0;
- }));
- }
- }
}
sub remove_accessors {
use strict;
use warnings;
+use Class::MOP::Method;
+
our $VERSION = '0.01';
our @ISA = ('Class::MOP::Method');
sub initialize {
my ($class, $package_name) = @_;
(defined $package_name && $package_name)
- || confess "You must pass a package name";
- $METAS{$package_name} ||= bless {
+ || confess "You must pass a package name";
+ return $METAS{$package_name} if exists $METAS{$package_name};
+ $METAS{$package_name} = $class->construct_class_instance($package_name);
+ }
+
+ # NOTE: (meta-circularity)
+ # this is a special form of &construct_instance
+ # (see below), which is used to construct class
+ # meta-object instances. It will be replaces in
+ # the bootstrap section in Class::MOP with one
+ # which uses the normal &construct_instance.
+ sub construct_class_instance {
+ my ($class, $package_name) = @_;
+ (defined $package_name && $package_name)
+ || confess "You must pass a package name";
+ bless {
'$:pkg' => $package_name,
'%:attrs' => {}
- } => blessed($class) || $class;
+ } => blessed($class) || $class
}
}
return @attrs;
}
-
1;
__END__
corresponding key in C<%params> or any default value or initializer
found in the attribute meta-object.
+=item B<construct_class_instance ($package_name)>
+
+This will construct an instance of B<Class::MOP::Class>, it is
+here so that we can actually "tie the knot" for B<Class::MOP::Class>
+to use C<construct_instance> once all the bootstrapping is done. This
+method is used internally by C<initialize> and should never be called
+from outside of that method really.
+
=back
=head2 Informational
use Carp 'confess';
use Scalar::Util 'reftype';
-use Class::MOP::Class;
-
our $VERSION = '0.01';
-sub meta { Class::MOP::Class->initialize($_[0]) }
+sub meta {
+ require Class::MOP::Class;
+ Class::MOP::Class->initialize($_[0])
+}
sub wrap {
my $class = shift;
{
package Foo;
- my $meta = __PACKAGE__->meta;
+ my $meta = Foo->meta;
::lives_ok {
$meta->add_attribute($FOO_ATTR);
} '... we added an attribute to Foo successfully';
package Bar;
our @ISA = ('Foo');
- my $meta = __PACKAGE__->meta;
+ my $meta = Bar->meta;
::lives_ok {
$meta->add_attribute($BAR_ATTR);
} '... we added an attribute to Bar successfully';
package Baz;
our @ISA = ('Bar');
- my $meta = __PACKAGE__->meta;
+ my $meta = Baz->meta;
::lives_ok {
$meta->add_attribute($BAZ_ATTR);
} '... we added an attribute to Baz successfully';
use Test::Exception;
BEGIN {
+ use_ok('Class::MOP');
use_ok('Class::MOP::Class');
}
ok(!$meta->has_method($non_method_name), '... NOT Class::MOP::Class->has_method(' . $non_method_name . ')');
}
+foreach my $attribute_name (
+ '$:pkg', '%:attrs'
+ ) {
+ ok($meta->has_attribute($attribute_name), '... Class::MOP::Class->has_attribute(' . $attribute_name . ')');
+ isa_ok($meta->get_attribute($attribute_name), 'Class::MOP::Attribute');
+}
+
is($meta->name, 'Class::MOP::Class', '... Class::MOP::Class->name');
is($meta->version, $Class::MOP::Class::VERSION, '... Class::MOP::Class->version');
use Test::Exception;
BEGIN {
+ use_ok('Class::MOP');
use_ok('Class::MOP::Attribute');
}
use Test::Exception;
BEGIN {
+ use_ok('Class::MOP');
use_ok('Class::MOP::Method');
}
use strict;
use warnings;
-use Test::More tests => 67;
+use Test::More tests => 68;
BEGIN {
+ use_ok('Class::MOP');
use_ok('t::lib::BinaryTree');
}
our $VERSION = '0.01';
__PACKAGE__->meta->add_attribute(
- Class::MOP::Attribute->new('_uid' => (
+ Class::MOP::Attribute->new('$:uid' => (
reader => 'getUID',
writer => 'setUID',
default => sub {
);
__PACKAGE__->meta->add_attribute(
- Class::MOP::Attribute->new('_node' => (
+ Class::MOP::Attribute->new('$:node' => (
reader => 'getNodeValue',
writer => 'setNodeValue',
init_arg => ':node'
);
__PACKAGE__->meta->add_attribute(
- Class::MOP::Attribute->new('_parent' => (
+ Class::MOP::Attribute->new('$:parent' => (
predicate => 'hasParent',
reader => 'getParent',
writer => 'setParent'
);
__PACKAGE__->meta->add_attribute(
- Class::MOP::Attribute->new('_left' => (
+ Class::MOP::Attribute->new('$:left' => (
predicate => 'hasLeft',
reader => 'getLeft',
writer => {
'setLeft' => sub {
my ($self, $tree) = @_;
$tree->setParent($self) if defined $tree;
- $self->{_left} = $tree;
+ $self->{'$:left'} = $tree;
$self;
}
},
);
__PACKAGE__->meta->add_attribute(
- Class::MOP::Attribute->new('_right' => (
+ Class::MOP::Attribute->new('$:right' => (
predicate => 'hasRight',
reader => 'getRight',
writer => {
'setRight' => sub {
my ($self, $tree) = @_;
$tree->setParent($self) if defined $tree;
- $self->{_right} = $tree;
+ $self->{'$:right'} = $tree;
$self;
}
}
projects / gitmo/Class-MOP.git / commitdiff