From: Stevan Little Date: Mon, 8 May 2006 19:34:18 +0000 (+0000) Subject: this-is-wrong X-Git-Tag: 0_29_02~9 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=6b96f5ab0771ffc7b3c4ddfc2e9a4e31379403af;p=gitmo%2FClass-MOP.git this-is-wrong --- diff --git a/Changes b/Changes index 7831c7e..8847997 100644 --- a/Changes +++ b/Changes @@ -1,6 +1,6 @@ Revision history for Perl extension Class-MOP. -0.30 Sat. May 6, 2006 +0.30 Mon. May 8, 2006 * Class::MOP::Class - anon-classes are now properly garbage collected - added tests for this diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 6036e45..9e06a4b 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -664,50 +664,63 @@ 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); - } +# we hold a weakened cache here +my %ANON_METAS; - sub construct_class_instance { - my ($class, %options) = @_; - my $package_name = $options{':package'}; +# 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; + +# prefix for all anon-class names +my $ANON_CLASS_PREFIX = __PACKAGE__ . '::SERIAL::'; + +sub initialize { + my $class = shift; + if ($_[0] =~ /^$ANON_CLASS_PREFIX/) { + $class->SUPER::initialize(@_); + } + else { # 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; + # we need to do this or weird + # things happen + Class::MOP::Class->initialize(@_); } } +sub create { + my ($class, %options) = @_; + my $package_name = $ANON_CLASS_PREFIX . ++$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+)/); + my ($serial_id) = ($self->name =~ /$ANON_CLASS_PREFIX(\d+)/); + #warn "destroying $prefix => $serial_id\n$self => ". $self->name; no strict 'refs'; - foreach my $key (keys %{$prefix . $serial_id}) { - delete ${$prefix . $serial_id}{$key}; + foreach my $key (keys %{$ANON_CLASS_PREFIX . $serial_id}) { + delete ${$ANON_CLASS_PREFIX . $serial_id}{$key}; } - delete ${'main::' . $prefix}{$serial_id . '::'}; + delete ${'main::' . $ANON_CLASS_PREFIX}{$serial_id . '::'}; } 1; diff --git a/t/018_anon_class.t b/t/018_anon_class.t index 25e55ef..d8d43fe 100644 --- a/t/018_anon_class.t +++ b/t/018_anon_class.t @@ -3,13 +3,22 @@ use strict; use warnings; -use Test::More tests => 9; +use Test::More tests => 16; use Test::Exception; BEGIN { use_ok('Class::MOP'); } +{ + package Foo; + use strict; + use warnings; + use metaclass; + + sub bar { 'Foo::bar' } +} + my $anon_class_id; { my $anon_class = Class::MOP::Class->create_anon_class(); @@ -18,17 +27,32 @@ my $anon_class_id; ($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'); + is_deeply( + [$anon_class->superclasses], + [], + '... got an empty superclass list'); + lives_ok { + $anon_class->superclasses('Foo'); + } '... can add a superclass to anon class'; + is_deeply( + [$anon_class->superclasses], + [ 'Foo' ], + '... got the right superclass list'); + + ok(!$anon_class->has_method('foo'), '... no foo method'); lives_ok { $anon_class->add_method('foo' => sub { "__ANON__::foo" }); } '... added a method to my anon-class'; + ok($anon_class->has_method('foo'), '... we have a foo method now'); my $instance = $anon_class->new_object(); isa_ok($instance, $anon_class->name); + isa_ok($instance, 'Foo'); is($instance->foo, '__ANON__::foo', '... got the right return value of our foo method'); + is($instance->bar, 'Foo::bar', '... got the right return value of our bar method'); } ok(!exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, '... the package no longer exists'); @@ -39,8 +63,8 @@ ok(!exists $main::Class::MOP::Class::__ANON__::SERIAL::{$anon_class_id . '::'}, # more than that, your probably mst my %conflicts; -foreach my $i (1 .. 1000) { +foreach my $i (1 .. 100) { $conflicts{ Class::MOP::Class->create_anon_class()->name } = undef; } -is(scalar(keys %conflicts), 1000, '... got as many classes as I would expect'); +is(scalar(keys %conflicts), 100, '... got as many classes as I would expect');