my $name = shift;
my %options = @_;
- (defined $name && $name ne '')
+ (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"
# 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});
+ foreach my $attr (@{$options{attributes}}) {
+ $meta->add_attribute($attr);
}
}
if (exists $options{methods}) {
# Instance Construction
sub construct_instance {
- my ($canidate, %params) = @_;
- # ...
+ my ($class, %params) = @_;
+ my $instance = {};
+ 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() if $attr->has_default();
+ # now add this to the instance structure
+ $instance->{$attr->name} = $val;
+ }
+ return $instance;
}
# Informational
=over 4
-=item B<construct_instance ($canidate, %params)>
+=item B<construct_instance (%params)>
-This will construct and instance using the C<$canidate> as storage
+This will construct and instance using a HASH ref as storage
(currently only HASH references are supported). This will collect all
the applicable attribute meta-objects and layout out the fields in the
-C<$canidate>, it will then initialize them using either use the
+HASH ref, it will then initialize them using either use the
corresponding key in C<%params> or any default value or initializer
found in the attribute meta-object.
use Test::More no_plan => 1;
BEGIN {
- use_ok('Class::MOP');
+ use_ok('Class::MOP' => '-> this-is-ignored :)');
use_ok('Class::MOP::Class');
use_ok('Class::MOP::Attribute');
use_ok('Class::MOP::Method');
},
],
'... got the right list of applicable attributes for Baz');
-}
+
+ my $attr;
+ lives_ok {
+ $attr = $meta->remove_attribute('$baz');
+ } '... removed the $baz attribute successfully';
+ is($attr, $BAZ_ATTR, '... got the right attribute back for Baz');
+
+ ok(!$meta->has_attribute('$baz'), '... Baz no longer has $baz attribute');
+
+ ok(!$meta->has_method('get_baz'), '... a reader has been removed');
+ ok(!$meta->has_method('set_baz'), '... a writer has been removed');
+
+ is_deeply(
+ [ sort { $a->{name} cmp $b->{name} } $meta->compute_all_applicable_attributes() ],
+ [
+ {
+ name => '$bar',
+ class => 'Bar',
+ attribute => $BAR_ATTR
+ },
+ {
+ name => '$foo',
+ class => 'Foo',
+ attribute => $FOO_ATTR
+ },
+ ],
+ '... got the right list of applicable attributes for Baz');
+
+ {
+ my $attr;
+ lives_ok {
+ $attr = Bar->meta->remove_attribute('$bar');
+ } '... removed the $bar attribute successfully';
+ is($attr, $BAR_ATTR, '... got the right attribute back for Bar');
+ ok(!Bar->meta->has_attribute('$bar'), '... Bar no longer has $bar attribute');
+ ok(!Bar->meta->has_method('bar'), '... a accessor has been removed');
+ }
+
+ is_deeply(
+ [ sort { $a->{name} cmp $b->{name} } $meta->compute_all_applicable_attributes() ],
+ [
+ {
+ name => '$foo',
+ class => 'Foo',
+ attribute => $FOO_ATTR
+ },
+ ],
+ '... got the right list of applicable attributes for Baz');
+
+}
--- /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 $Point = Class::MOP::Class->create('Point' => '0.01' => (
+ attributes => [
+ Class::MOP::Attribute->new('$.x' => (
+ reader => 'x',
+ init_arg => 'x'
+ )),
+ Class::MOP::Attribute->new('$.y' => (
+ accessor => 'y',
+ init_arg => 'y'
+ )),
+ ],
+ methods => {
+ 'new' => sub {
+ my $class = shift;
+ my $instance = $class->meta->construct_instance(@_);
+ bless $instance => $class;
+ },
+ 'clear' => sub {
+ my $self = shift;
+ $self->{'$.x'} = 0;
+ $self->{'$.y'} = 0;
+ }
+ }
+));
+
+my $Point3D = Class::MOP::Class->create('Point3D' => '0.01' => (
+ superclasses => [ 'Point' ],
+ attributes => [
+ Class::MOP::Attribute->new('$:z' => (
+ default => 123
+ )),
+ ],
+ methods => {
+ 'clear' => sub {
+ my $self = shift;
+ $self->{'$:z'} = 0;
+ $self->SUPER::clear();
+ }
+ }
+));
+
+isa_ok($Point, 'Class::MOP::Class');
+isa_ok($Point3D, 'Class::MOP::Class');
+
+# ... test the classes themselves
+
+my $point = Point->new('x' => 2, 'y' => 3);
+isa_ok($point, 'Point');
+
+can_ok($point, 'x');
+can_ok($point, 'y');
+can_ok($point, 'clear');
+
+{
+ my $meta = $point->meta;
+ is($meta, Point->meta(), '... got the meta from the instance too');
+}
+
+is($point->y, 3, '... the $.y attribute was initialized correctly through the metaobject');
+
+$point->y(42);
+is($point->y, 42, '... the $.y attribute was set properly with the accessor');
+
+is($point->x, 2, '... the $.x attribute was initialized correctly through the metaobject');
+
+$point->x(42);
+is($point->x, 2, '... the $.x attribute was not altered');
+
+$point->clear();
+
+is($point->y, 0, '... the $.y attribute was cleared correctly');
+is($point->x, 0, '... the $.x attribute was cleared correctly');
+
+my $point3d = Point3D->new('x' => 1, 'y' => 2, '$:z' => 3);
+isa_ok($point3d, 'Point3D');
+isa_ok($point3d, 'Point');
+
+{
+ my $meta = $point3d->meta;
+ is($meta, Point3D->meta(), '... got the meta from the instance too');
+}
+
+can_ok($point3d, 'x');
+can_ok($point3d, 'y');
+can_ok($point3d, 'clear');
+
+is($point3d->x, 1, '... the $.x attribute was initialized correctly through the metaobject');
+is($point3d->y, 2, '... the $.y attribute was initialized correctly through the metaobject');
+is($point3d->{'$:z'}, 3, '... the $:z attribute was initialized correctly through the metaobject');
+
+{
+ my $point3d = Point3D->new();
+ isa_ok($point3d, 'Point3D');
+
+ is($point3d->x, undef, '... the $.x attribute was not initialized');
+ is($point3d->y, undef, '... the $.y attribute was not initialized');
+ is($point3d->{'$:z'}, 123, '... the $:z attribute was initialized correctly through the metaobject');
+
+}
+
+
}
dies_ok {
- my $attr = Class::MOP::Attribute->new('$foo', (
+ 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', (
+ 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', (
+ Class::MOP::Attribute->new('$foo', (
accessor => 'foo',
reader => 'get_foo',
writer => 'set_foo',
));
} '... cannot create accessors with reader/writers';
+dies_ok {
+ Class::MOP::Attribute->new();
+} '... no name argument';
+
+dies_ok {
+ Class::MOP::Attribute->new('');
+} '... bad name argument';
+
+dies_ok {
+ Class::MOP::Attribute->new(0);
+} '... bad name argument';
+
+dies_ok {
+ Class::MOP::Attribute->install_accessors();
+} '... bad install_accessors argument';
+
+dies_ok {
+ Class::MOP::Attribute->install_accessors(bless {} => 'Fail');
+} '... bad install_accessors argument';
+
+dies_ok {
+ Class::MOP::Attribute->remove_accessors();
+} '... bad remove_accessors argument';
+
+dies_ok {
+ Class::MOP::Attribute->remove_accessors(bless {} => 'Fail');
+} '... bad remove_accessors argument';
+
{
my $meta = Class::MOP::Attribute->meta();
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP::Method');
+}
+
+my $meta = Class::MOP::Method->meta;
+isa_ok($meta, 'Class::MOP::Class');
+
+
+{
+ my $meta = Class::MOP::Method->meta();
+ isa_ok($meta, 'Class::MOP::Class');
+
+ foreach my $method_name (qw(
+ meta
+ wrap
+ )) {
+ ok($meta->has_method($method_name), '... Class::MOP::Method->has_method(' . $method_name . ')');
+ }
+}
+
+dies_ok {
+ Class::MOP::Method->wrap()
+} '... bad args for &wrap';
+
+dies_ok {
+ Class::MOP::Method->wrap('Fail')
+} '... bad args for &wrap';
+
+dies_ok {
+ Class::MOP::Method->wrap([])
+} '... bad args for &wrap';
\ No newline at end of file
projects / gitmo/Class-MOP.git / commitdiff