Revision history for Perl extension Class-MOP.
0.30 Sat. May 6, 2006
+ * Class::MOP::Class
+ - anon-classes are now properly garbage collected
+ - added tests for this
+
* Class::MOP::Instance
- added new instance protocol
- added tests for this
made for these tools to keep to the spirit of the Perl 5 object
system that we all know and love.
+This documentation is admittedly sparse on details, as time permits
+I will try to improve them. For now, I suggest looking at the items
+listed in the L<SEE ALSO> section for more information. In particular
+the book "The Art of the Meta Object Protocol" was very influential
+in the development of this system.
+
=head2 What is a Meta Object Protocol?
A meta object protocol is an API to an object system.
---------------------------- ------ ------ ------ ------ ------ ------ ------
File stmt bran cond sub pod time total
---------------------------- ------ ------ ------ ------ ------ ------ ------
- Class/MOP.pm 100.0 100.0 100.0 100.0 n/a 9.6 100.0
- Class/MOP/Attribute.pm 100.0 100.0 91.7 73.8 100.0 28.4 92.1
- Class/MOP/Class.pm 100.0 93.5 82.3 98.2 100.0 56.6 95.7
- Class/MOP/Method.pm 100.0 64.3 52.9 80.0 100.0 3.5 85.3
- metaclass.pm 100.0 100.0 80.0 100.0 n/a 1.9 97.4
+ Class/MOP.pm 100.0 100.0 100.0 100.0 n/a 24.3 100.0
+ Class/MOP/Attribute.pm 100.0 100.0 91.7 63.6 100.0 9.2 88.8
+ Class/MOP/Class.pm 98.1 91.8 77.3 96.8 100.0 58.3 93.3
+ Class/MOP/Instance.pm 87.5 100.0 0.0 87.5 100.0 5.9 88.0
+ Class/MOP/Method.pm 100.0 64.3 52.9 80.0 100.0 1.4 85.3
+ metaclass.pm 100.0 100.0 83.3 100.0 n/a 0.9 97.7
---------------------------- ------ ------ ------ ------ ------ ------ ------
- Total 100.0 90.8 79.7 86.2 100.0 100.0 93.6
+ Total 97.8 90.1 74.8 82.9 100.0 100.0 91.5
---------------------------- ------ ------ ------ ------ ------ ------ ------
=head1 ACKNOWLEDGEMENTS
# it is safe to use meta here because
# class will always be a subclass of
# Class::MOP::Class, which defines meta
- $meta = bless $class->meta->construct_instance(%options) => $class
+ $meta = $class->meta->construct_instance(%options)
}
# and check the metaclass compatibility
$meta->check_metaclass_compatability();
return $meta;
}
-{
- # NOTE:
- # this should be sufficient, if you have a
- # use case where it is not, write a test and
- # I will change it.
- my $ANON_CLASS_SERIAL = 0;
- sub create_anon_class {
- my ($class, %options) = @_;
- my $package_name = 'Class::MOP::Class::__ANON__::SERIAL::' . ++$ANON_CLASS_SERIAL;
- return $class->create($package_name, '0.00', %options);
- }
+sub create_anon_class {
+ my ($class, %options) = @_;
+ return Class::MOP::Class::__ANON__->create(%options);
}
## Attribute readers
delete ${$self->name . '::'}{$name};
}
+package Class::MOP::Class::__ANON__;
+
+use strict;
+use warnings;
+
+use Scalar::Util 'weaken';
+
+our $VERSION = '0.01';
+
+use base 'Class::MOP::Class';
+
+{
+ # NOTE:
+ # we hold a weakened cache here
+ my %ANON_METAS;
+
+ # NOTE:
+ # this should be sufficient, if you have a
+ # use case where it is not, write a test and
+ # I will change it.
+ my $ANON_CLASS_SERIAL = 0;
+
+ sub create {
+ my ($class, %options) = @_;
+ my $package_name = __PACKAGE__ . '::SERIAL::' . ++$ANON_CLASS_SERIAL;
+ return $class->SUPER::create($package_name, '0.00', %options);
+ }
+
+ sub construct_class_instance {
+ my ($class, %options) = @_;
+ my $package_name = $options{':package'};
+ # NOTE:
+ # we cache the anon metaclasses as well
+ # but we weaken them (see below)
+ return $ANON_METAS{$package_name}
+ if exists $ANON_METAS{$package_name} &&
+ defined $ANON_METAS{$package_name};
+ my $meta = $class->meta->construct_instance(%options);
+ $meta->check_metaclass_compatability();
+ # weaken the metaclass cache so that
+ # DESTROY gets called as expected
+ weaken($ANON_METAS{$package_name} = $meta);
+ return $meta;
+ }
+}
+
+sub DESTROY {
+ my $self = shift;
+ my $prefix = __PACKAGE__ . '::SERIAL::';
+ my ($serial_id) = ($self->name =~ /$prefix(\d+)/);
+ no strict 'refs';
+ foreach my $key (keys %{$prefix . $serial_id}) {
+ delete ${$prefix . $serial_id}{$key};
+ }
+ delete ${'main::' . $prefix}{$serial_id . '::'};
+}
+
1;
__END__
use strict;
use warnings;
-use Test::More tests => 7;
+use Test::More tests => 9;
use Test::Exception;
BEGIN {
use_ok('Class::MOP');
}
-my $anon_class = Class::MOP::Class->create_anon_class();
-isa_ok($anon_class, 'Class::MOP::Class');
-
-like($anon_class->name, qr/Class::MOP::Class::__ANON__::SERIAL::[0-9]+/, '... got an anon class package name');
-
-lives_ok {
- $anon_class->add_method('foo' => sub { "__ANON__::foo" });
-} '... added a method to my anon-class';
-
-my $instance = $anon_class->new_object();
-isa_ok($instance, $anon_class->name);
+my $anon_class_id;
+{
+ my $anon_class = Class::MOP::Class->create_anon_class();
+ isa_ok($anon_class, 'Class::MOP::Class');
+
+ ($anon_class_id) = ($anon_class->name =~ /Class::MOP::Class::__ANON__::SERIAL::(\d+)/);
+
+ ok(exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package exists');
+
+ like($anon_class->name, qr/Class::MOP::Class::__ANON__::SERIAL::[0-9]+/, '... got an anon class package name');
+
+ lives_ok {
+ $anon_class->add_method('foo' => sub { "__ANON__::foo" });
+ } '... added a method to my anon-class';
+
+ my $instance = $anon_class->new_object();
+ isa_ok($instance, $anon_class->name);
+
+ is($instance->foo, '__ANON__::foo', '... got the right return value of our foo method');
+}
-is($instance->foo, '__ANON__::foo', '... got the right return value of our foo method');
+ok(!exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package no longer exists');
# NOTE:
# I bumped this test up to 100_000 instances, and
projects / gitmo/Class-MOP.git / commitdiff