From: Stevan Little Date: Mon, 8 May 2006 18:15:02 +0000 (+0000) Subject: foo X-Git-Tag: 0_29_02~10 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4048309555306b4863589e1ff580a59a5703ea14;p=gitmo%2FClass-MOP.git foo --- diff --git a/Changes b/Changes index e8ebd02..7831c7e 100644 --- a/Changes +++ b/Changes @@ -1,6 +1,10 @@ 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 diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 99afc6f..ccc1081 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -211,6 +211,12 @@ set of extensions to the Perl 5 object system. Every attempt has been 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 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. @@ -439,13 +445,14 @@ L 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 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 diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 0be9bf5..6036e45 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -85,7 +85,7 @@ sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) } # 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(); @@ -154,18 +154,10 @@ sub create { 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 @@ -661,6 +653,63 @@ sub remove_package_variable { 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__ diff --git a/t/018_anon_class.t b/t/018_anon_class.t index 6534662..25e55ef 100644 --- a/t/018_anon_class.t +++ b/t/018_anon_class.t @@ -3,26 +3,35 @@ 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