From: Stevan Little Date: Mon, 30 Jan 2006 21:26:12 +0000 (+0000) Subject: getting closer X-Git-Tag: 0_02~15 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=cbd9f94236f2c6be75aafbf52b796c754bc4d941;p=gitmo%2FClass-MOP.git getting closer --- diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 6cfeff7..8f3a80d 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -19,7 +19,7 @@ sub new { 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" diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index cf0d160..82b4744 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -52,8 +52,8 @@ sub create { # 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}) { @@ -67,8 +67,22 @@ sub create { # 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 @@ -355,12 +369,12 @@ This initializes a Class object for a given a C<$package_name>. =over 4 -=item B +=item B -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. diff --git a/t/000_load.t b/t/000_load.t index 2a37287..4836c63 100644 --- a/t/000_load.t +++ b/t/000_load.t @@ -6,7 +6,7 @@ use warnings; 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'); diff --git a/t/005_attributes.t b/t/005_attributes.t index cb93fae..1b16ea0 100644 --- a/t/005_attributes.t +++ b/t/005_attributes.t @@ -87,6 +87,55 @@ my $BAZ_ATTR = Class::MOP::Attribute->new('$baz' => ( }, ], '... 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'); + +} diff --git a/t/011_create_class.t b/t/011_create_class.t new file mode 100644 index 0000000..66cb130 --- /dev/null +++ b/t/011_create_class.t @@ -0,0 +1,113 @@ +#!/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'); + +} + + diff --git a/t/020_attribute.t b/t/020_attribute.t index 57b1917..3e8daf7 100644 --- a/t/020_attribute.t +++ b/t/020_attribute.t @@ -89,27 +89,55 @@ BEGIN { } 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(); diff --git a/t/030_method.t b/t/030_method.t new file mode 100644 index 0000000..b0d4923 --- /dev/null +++ b/t/030_method.t @@ -0,0 +1,39 @@ +#!/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