Revision history for Perl extension Class-MOP.
0.07
- - adding more tests
+ - adding more tests to get coverage up a little higher,
+ mostly testing errors and edge cases.
+ - test coverage is now at 99%
* Class::MOP
- no longer optionally exports to UNIVERSAL::meta or
creates a custom metaclass generator, use the
metaclass pragma instead.
-
+
+ * Class::MOP::Class
+ - fixed a number of minor issues which came up in the
+ error/edge-case tests
+
+ * Class::MOP::Attribute
+ - fixed a number of minor issues which came up in the
+ error/edge-case tests
+
* examples/
- fixing the AttributesWithHistory example, it was broken.
exception. If you find a bug please either email me, or add the bug
to cpan-RT.
+=head1 CODE COVERAGE
+
+I use L<Devel::Cover> to test the code coverage of my tests, below is the
+L<Devel::Cover> report on this module's test suite.
+
+ ---------------------------- ------ ------ ------ ------ ------ ------ ------
+ File stmt bran cond sub pod time total
+ ---------------------------- ------ ------ ------ ------ ------ ------ ------
+ Class/MOP.pm 100.0 100.0 100.0 100.0 n/a 21.4 100.0
+ Class/MOP/Attribute.pm 100.0 100.0 88.9 100.0 100.0 27.1 99.3
+ Class/MOP/Class.pm 100.0 100.0 93.7 100.0 100.0 44.8 99.1
+ Class/MOP/Method.pm 100.0 100.0 83.3 100.0 100.0 4.8 97.1
+ metaclass.pm 100.0 100.0 80.0 100.0 n/a 1.9 97.3
+ ---------------------------- ------ ------ ------ ------ ------ ------ ------
+ Total 100.0 100.0 92.2 100.0 100.0 100.0 99.0
+ ---------------------------- ------ ------ ------ ------ ------ ------ ------
+
=head1 ACKNOWLEDGEMENTS
=over 4
sub initialize {
my $class = shift;
my $package_name = shift;
- (defined $package_name && $package_name)
- || confess "You must pass a package name";
- # make sure the package name is not blessed
- $package_name = blessed($package_name) || $package_name;
+ (defined $package_name && $package_name && !blessed($package_name))
+ || confess "You must pass a package name and it cannot be blessed";
$class->construct_class_instance(':package' => $package_name, @_);
}
no strict 'refs';
no warnings 'redefine';
-# *{$full_method_name} = subname $full_method_name => $method;
- *{$full_method_name} = $method;
+ *{$full_method_name} = subname $full_method_name => $method;
}
sub alias_method {
(defined $attribute_name && $attribute_name)
|| confess "You must define an attribute name";
return $self->get_attribute_map->{$attribute_name}
- if $self->has_attribute($attribute_name);
+ if $self->has_attribute($attribute_name);
+ return;
}
sub remove_attribute {
(defined $attribute_name && $attribute_name)
|| confess "You must define an attribute name";
my $removed_attribute = $self->get_attribute_map->{$attribute_name};
- delete $self->get_attribute_map->{$attribute_name}
- if defined $removed_attribute;
+ return unless defined $removed_attribute;
+ delete $self->get_attribute_map->{$attribute_name};
$removed_attribute->remove_accessors();
$removed_attribute->detach_from_class();
return $removed_attribute;
use strict;
use warnings;
-use Carp 'confess';
+use Carp 'confess';
+use Scalar::Util 'blessed';
-our $VERSION = '0.01';
+our $VERSION = '0.02';
use Class::MOP;
# since metaclass instances are
# singletons, this is not really a
# big deal anyway.
- $metaclass->initialize($_[0] => %options)
+ $metaclass->initialize((blessed($_[0]) || $_[0]) => %options)
});
}
package Baz;
our @ISA = ('Bar');
- sub BUILD { 'Baz::BUILD' }
sub baz { 'Baz::baz' }
sub foo { 'Baz::foo' }
is_deeply(
[ sort { $a->{name} cmp $b->{name} } Class::MOP::Class->initialize('Baz')->compute_all_applicable_methods() ],
- [
+ [
{
name => 'BUILD',
- class => 'Baz',
- code => \&Baz::BUILD
+ class => 'Bar',
+ code => \&Bar::BUILD
},
{
name => 'bar',
name => 'BUILD',
class => 'Bar',
code => \&Bar::BUILD
- },
- {
- name => 'BUILD',
- class => 'Baz',
- code => \&Baz::BUILD
- },
+ },
],
'... got the right list of BUILD methods for Foo::Bar::Baz');
\ No newline at end of file
use strict;
use warnings;
-use Test::More tests => 33;
+use Test::More tests => 40;
use Test::Exception;
BEGIN {
writer => 'set_baz',
));
+my $BAR_ATTR_2 = Class::MOP::Attribute->new('$bar');
+
{
package Foo;
use metaclass;
::is($meta->get_attribute('$foo'), $FOO_ATTR, '... got the right attribute back for Foo');
::ok(!$meta->has_method('foo'), '... no accessor created');
+
+ ::lives_ok {
+ $meta->add_attribute($BAR_ATTR_2);
+ } '... we added an attribute to Foo successfully';
+ ::ok($meta->has_attribute('$bar'), '... Foo has $bar attribute');
+ ::is($meta->get_attribute('$bar'), $BAR_ATTR_2, '... got the right attribute back for Foo');
+
+ ::ok(!$meta->has_method('bar'), '... no accessor created');
}
{
package Bar;
::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');
+ ::isa_ok($meta->get_method('bar'), 'Class::MOP::Attribute::Accessor');
}
{
package Baz;
is($attr, $BAZ_ATTR, '... got the right attribute back for Baz');
ok(!$meta->has_attribute('$baz'), '... Baz no longer has $baz attribute');
+ is($meta->get_attribute('$baz'), undef, '... 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() ],
[
+ $BAR_ATTR_2,
$FOO_ATTR,
],
'... got the right list of applicable attributes for Baz');
is_deeply(
[ map { $_->associated_class } sort { $a->name cmp $b->name } $meta->compute_all_applicable_attributes() ],
- [ Foo->meta ],
+ [ Foo->meta, Foo->meta ],
'... got the right list of associated classes from the applicable attributes for Baz');
+ # remove attribute which is not there
+ my $val;
+ lives_ok {
+ $val = $meta->remove_attribute('$blammo');
+ } '... attempted to remove the non-existent $blammo attribute';
+ is($val, undef, '... got the right value back (undef)');
+
}
use strict;
use warnings;
-use Test::More no_plan => 1;
+use Test::More tests => 53;
use Test::Exception;
BEGIN {
use_ok('Class::MOP');
-}
\ No newline at end of file
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->initialize();
+ } '... initialize requires a name parameter';
+
+ dies_ok {
+ Class::MOP::Class->initialize('');
+ } '... initialize requires a name valid parameter';
+
+ dies_ok {
+ Class::MOP::Class->initialize(bless {} => 'Foo');
+ } '... initialize requires an unblessed parameter'
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->construct_class_instance();
+ } '... construct_class_instance requires an :package parameter';
+
+ dies_ok {
+ Class::MOP::Class->construct_class_instance(':package' => undef);
+ } '... construct_class_instance requires a defined :package parameter';
+
+ dies_ok {
+ Class::MOP::Class->construct_class_instance(':package' => '');
+ } '... construct_class_instance requires a valid :package parameter';
+}
+
+
+{
+ dies_ok {
+ Class::MOP::Class->create();
+ } '... create requires an package_name parameter';
+
+ dies_ok {
+ Class::MOP::Class->create(undef);
+ } '... create requires a defined package_name parameter';
+
+ dies_ok {
+ Class::MOP::Class->create('');
+ } '... create requires a valid package_name parameter';
+
+ throws_ok {
+ Class::MOP::Class->create('+++');
+ } qr/^creation of \+\+\+ failed/, '... create requires a valid package_name parameter';
+
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->clone_object(1);
+ } '... can only clone instances';
+
+ dies_ok {
+ Class::MOP::Class->clone_instance(1);
+ } '... can only clone instances';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->add_method();
+ } '... add_method dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->add_method('');
+ } '... add_method dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->add_method('foo' => 'foo');
+ } '... add_method dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->add_method('foo' => []);
+ } '... add_method dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->alias_method();
+ } '... alias_method dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->alias_method('');
+ } '... alias_method dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->alias_method('foo' => 'foo');
+ } '... alias_method dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->alias_method('foo' => []);
+ } '... alias_method dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->has_method();
+ } '... has_method dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->has_method('');
+ } '... has_method dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->get_method();
+ } '... get_method dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->get_method('');
+ } '... get_method dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->remove_method();
+ } '... remove_method dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->remove_method('');
+ } '... remove_method dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->find_all_methods_by_name();
+ } '... find_all_methods_by_name dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->find_all_methods_by_name('');
+ } '... find_all_methods_by_name dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->add_attribute(bless {} => 'Foo');
+ } '... add_attribute dies as expected';
+}
+
+
+{
+ dies_ok {
+ Class::MOP::Class->has_attribute();
+ } '... has_attribute dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->has_attribute('');
+ } '... has_attribute dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->get_attribute();
+ } '... get_attribute dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->get_attribute('');
+ } '... get_attribute dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->remove_attribute();
+ } '... remove_attribute dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->remove_attribute('');
+ } '... remove_attribute dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->add_package_variable();
+ } '... add_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->add_package_variable('');
+ } '... add_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->add_package_variable('foo');
+ } '... add_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->add_package_variable('&foo');
+ } '... add_package_variable dies as expected';
+
+ throws_ok {
+ Class::MOP::Class->meta->add_package_variable('@-');
+ } qr/^Could not create package variable \(\@\-\) because/,
+ '... add_package_variable dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->has_package_variable();
+ } '... has_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->has_package_variable('');
+ } '... has_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->has_package_variable('foo');
+ } '... has_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->has_package_variable('&foo');
+ } '... has_package_variable dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->get_package_variable();
+ } '... get_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->get_package_variable('');
+ } '... get_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->get_package_variable('foo');
+ } '... get_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->get_package_variable('&foo');
+ } '... get_package_variable dies as expected';
+}
+
+{
+ dies_ok {
+ Class::MOP::Class->remove_package_variable();
+ } '... remove_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->remove_package_variable('');
+ } '... remove_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->remove_package_variable('foo');
+ } '... remove_package_variable dies as expected';
+
+ dies_ok {
+ Class::MOP::Class->remove_package_variable('&foo');
+ } '... remove_package_variable dies as expected';
+}
+
use strict;
use warnings;
-use Test::More tests => 52;
+use Test::More tests => 58;
use Test::Exception;
BEGIN {
is_deeply($attr, $attr_clone, '... but they are the same inside');
}
+
+{
+ my $attr = Class::MOP::Attribute->new('$foo');
+ isa_ok($attr, 'Class::MOP::Attribute');
+
+ my $attr_clone = $attr->clone('name' => '$bar');
+ isa_ok($attr_clone, 'Class::MOP::Attribute');
+ isnt($attr, $attr_clone, '... but they are different instances');
+
+ isnt($attr->name, $attr_clone->name, '... we changes the name parameter');
+
+ is($attr->name, '$foo', '... $attr->name == $foo');
+ is($attr_clone->name, '$bar', '... $attr_clone->name == $bar');
+}
+
use strict;
use warnings;
-use Test::More tests => 8;
+use Test::More tests => 9;
use Test::Exception;
BEGIN {
use_ok('Class::MOP::Method');
}
+{
+ my $method = Class::MOP::Method->wrap(sub { 1 });
+ is($method->meta, Class::MOP::Method->meta, '... instance and class both lead to the same meta');
+}
+
my $meta = Class::MOP::Method->meta;
isa_ok($meta, 'Class::MOP::Class');
projects / gitmo/Class-MOP.git / commitdiff