From: Stevan Little Date: Mon, 19 May 2008 13:23:05 +0000 (+0000) Subject: putting the cache experiment in a branch X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=722a4ac102084ff4a45655916c7e20508b9820cc;p=gitmo%2FClass-MOP.git putting the cache experiment in a branch --- diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 439ac91..ca07a0a 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -165,6 +165,68 @@ sub is_class_loaded { # ... nothing yet actually ;) +use Storable; + +my $MOP_CACHE_FILE = 'Class_MOP.cache'; + +#warn ((stat $INC{'Class/MOP.pm'})[9]); +#warn ((stat $MOP_CACHE_FILE)[9]); + +if (-e $MOP_CACHE_FILE && (stat $INC{'Class/MOP.pm'})[9] < (stat $MOP_CACHE_FILE)[9]) { + $Storable::Eval = 1; + my $cache = Storable::retrieve($MOP_CACHE_FILE); + + # now we do 2 things, first is to grab + # the cached metaclass, and second is + # to make sure that we reinstall any + # methods we installed in the bootstrap + # process, this is typically constructors + # and clone methods + + my %methods; + + foreach my $meta_name (keys %{$cache->{metas}}) { + my $metaclass = $cache->{metas}->{$meta_name}; + + # before we do anything to the + # metaclasses, we need to grab the + # methods we added in the bootstrap + # because any calls to get_method_map + # will cause it to grab the ones + # that are on disk, and not in the + # bootstrap. + $methods{$meta_name} = []; + + foreach my $method_to_reinstall (@{$cache->{methods_to_reinstall}->{$meta_name}}) { + #use Data::Dumper; + #$Data::Dumper::Deparse = 1; + #warn Dumper $metaclass->{'%!methods'}->{$method_to_reinstall}; + push @{ $methods{$meta_name} } => { + name => $method_to_reinstall, + method => $metaclass->{'%!methods'}->{$method_to_reinstall}, + }; + } + + store_metaclass_by_name($meta_name, $metaclass); + } + + # now we can start adding methods + # so that we get the properly + # bootstrapped versions of them + foreach my $meta_name (keys %methods) { + my $metaclass = $cache->{metas}->{$meta_name}; + foreach my $method_to_install (@{ $methods{$meta_name} }) { + $metaclass->add_method( + $method_to_install->{name}, + $method_to_install->{method} + ); + } + } +} +else { + +my %methods_to_reinstall; + ## ---------------------------------------------------------------------------- ## Bootstrapping ## ---------------------------------------------------------------------------- @@ -220,6 +282,8 @@ Class::MOP::Package->meta->add_method('initialize' => sub { $class->meta->new_object('package' => $package_name, @_); }); +$methods_to_reinstall{'Class::MOP::Package'} = [qw[initialize]]; + ## -------------------------------------------------------- ## Class::MOP::Module @@ -506,6 +570,8 @@ Class::MOP::Attribute->meta->add_method('clone' => sub { $self->meta->clone_object($self, @_); }); +$methods_to_reinstall{'Class::MOP::Attribute'} = [qw[new clone]]; + ## -------------------------------------------------------- ## Class::MOP::Method @@ -550,6 +616,8 @@ Class::MOP::Method->meta->add_method('clone' => sub { $self->meta->clone_object($self, @_); }); +$methods_to_reinstall{'Class::MOP::Method'} = [qw[wrap clone]]; + ## -------------------------------------------------------- ## Class::MOP::Method::Wrapped @@ -582,6 +650,8 @@ Class::MOP::Method::Generated->meta->add_method('new' => sub { $self; }); +$methods_to_reinstall{'Class::MOP::Method::Generated'} = [qw[new]]; + ## -------------------------------------------------------- ## Class::MOP::Method::Accessor @@ -630,6 +700,7 @@ Class::MOP::Method::Accessor->meta->add_method('new' => sub { $self; }); +$methods_to_reinstall{'Class::MOP::Method::Accessor'} = [qw[new]]; ## -------------------------------------------------------- ## Class::MOP::Method::Constructor @@ -677,6 +748,8 @@ Class::MOP::Method::Constructor->meta->add_method('new' => sub { $self; }); +$methods_to_reinstall{'Class::MOP::Method::Constructor'} = [qw[new]]; + ## -------------------------------------------------------- ## Class::MOP::Instance @@ -702,6 +775,28 @@ Class::MOP::Instance->meta->add_attribute( # time of the MOP, and gives us # no actual benefits. +unless ($ENV{CLASS_MOP_NO_CACHE}) { + my %metaclasses_to_store = get_all_metaclasses(); + $Storable::Deparse = 1; + Storable::nstore({ + metas => \%metaclasses_to_store, + methods_to_reinstall => \%methods_to_reinstall + }, $MOP_CACHE_FILE); + + #foreach my $meta_name (keys %metaclasses_to_store) { + # my $metaclass = $metaclasses_to_store{$meta_name}; + # foreach my $method_to_reinstall (@{$methods_to_reinstall{$meta_name}}) { + # warn "CHECKING $method_to_reinstall"; + # + # use Data::Dumper; + # $Data::Dumper::Deparse = 1; + # warn Dumper $metaclass->{'%!methods'}->{$method_to_reinstall}; + # } + #} +} + +} + $_->meta->make_immutable( inline_constructor => 0, inline_accessors => 0, diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t index d321c63..29991a5 100644 --- a/t/010_self_introspection.t +++ b/t/010_self_introspection.t @@ -217,9 +217,8 @@ is($class_mop_package_meta->get_attribute('$!package')->init_arg, 'package', '.. # ... class ok($class_mop_class_meta->get_attribute('%!attributes')->has_reader, '... Class::MOP::Class %!attributes has a reader'); -is_deeply($class_mop_class_meta->get_attribute('%!attributes')->reader, - { 'get_attribute_map' => \&Class::MOP::Class::get_attribute_map }, - '... Class::MOP::Class %!attributes\'s a reader is &get_attribute_map'); +is(ref($class_mop_class_meta->get_attribute('%!attributes')->reader), + 'HASH', '... Class::MOP::Class %!attributes\'s a reader is a HASH'); ok($class_mop_class_meta->get_attribute('%!attributes')->has_init_arg, '... Class::MOP::Class %!attributes has a init_arg'); is($class_mop_class_meta->get_attribute('%!attributes')->init_arg, @@ -232,9 +231,8 @@ is_deeply($class_mop_class_meta->get_attribute('%!attributes')->default('Foo'), '... Class::MOP::Class %!attributes\'s a default of {}'); ok($class_mop_class_meta->get_attribute('$!attribute_metaclass')->has_reader, '... Class::MOP::Class $!attribute_metaclass has a reader'); -is_deeply($class_mop_class_meta->get_attribute('$!attribute_metaclass')->reader, - { 'attribute_metaclass' => \&Class::MOP::Class::attribute_metaclass }, - '... Class::MOP::Class $!attribute_metaclass\'s a reader is &attribute_metaclass'); +is(ref($class_mop_class_meta->get_attribute('$!attribute_metaclass')->reader), + 'HASH', '... Class::MOP::Class $!attribute_metaclass\'s a reader is a HASH'); ok($class_mop_class_meta->get_attribute('$!attribute_metaclass')->has_init_arg, '... Class::MOP::Class $!attribute_metaclass has a init_arg'); is($class_mop_class_meta->get_attribute('$!attribute_metaclass')->init_arg, @@ -247,9 +245,8 @@ is($class_mop_class_meta->get_attribute('$!attribute_metaclass')->default, '... Class::MOP::Class $!attribute_metaclass\'s a default is Class::MOP:::Attribute'); ok($class_mop_class_meta->get_attribute('$!method_metaclass')->has_reader, '... Class::MOP::Class $!method_metaclass has a reader'); -is_deeply($class_mop_class_meta->get_attribute('$!method_metaclass')->reader, - { 'method_metaclass' => \&Class::MOP::Class::method_metaclass }, - '... Class::MOP::Class $!method_metaclass\'s a reader is &method_metaclass'); +is(ref($class_mop_class_meta->get_attribute('$!method_metaclass')->reader), + 'HASH', '... Class::MOP::Class $!method_metaclass\'s a reader is a HASH'); ok($class_mop_class_meta->get_attribute('$!method_metaclass')->has_init_arg, '... Class::MOP::Class $!method_metaclass has a init_arg'); is($class_mop_class_meta->get_attribute('$!method_metaclass')->init_arg,