From: Matt S Trout <matthewt@hercule.scsys.co.uk>
Date: Sat, 5 Dec 2009 07:40:31 +0000 (+0000)
Subject: metaclass dumping
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMooseX-Antlers.git;a=commitdiff_plain;h=3691d03f42d4f21f78221c4d6edb9d03a950c896

metaclass dumping
---

diff --git a/lib/MooseX/Antlers/Compiler.pm b/lib/MooseX/Antlers/Compiler.pm
index 0d9e437..0c0345a 100644
--- a/lib/MooseX/Antlers/Compiler.pm
+++ b/lib/MooseX/Antlers/Compiler.pm
@@ -4,6 +4,8 @@ use Moose;
 use IO::All qw(io);
 use String::TT qw(strip tt);
 use B qw(perlstring);
+use Data::Dumper::Concise;
+use Scalar::Util qw(refaddr);
 use aliased 'MooseX::Antlers::RefTracker';
 use aliased 'MooseX::Antlers::EvalTracker';
 use aliased 'MooseX::Antlers::RefFilter';
@@ -64,16 +66,15 @@ sub compiled_source {
   my $im_et = $self->_im_et;
   my $target = $self->_target;
   my %attr_construct;
+  my $all_refs = { map %{$_->[1]}, values %attr_refs };
   foreach my $attr_name (keys %attr_refs) {
     $attr_construct{$attr_name}
       = $attr_et{$attr_name}->serialized_construction(
           $attr_refs{$attr_name}[0]
         );
   }
-  my $im_construct = $im_et->serialized_construction(
-    { map %{$_->[1]}, values %attr_refs }
-  );
-  my $preamble = strip tt q{
+  my $im_construct = $im_et->serialized_construction($all_refs);
+  my $preamble = tt strip q{
     my %replay_has;
     my %has_args;
     BEGIN {
@@ -86,7 +87,15 @@ sub compiled_source {
       );
     }
     sub MooseX::Antlers::ImmutableHackFor::[% target %]::make_immutable {
-  [% im_construct %]
+      [% im_construct %]
+      no warnings 'redefine';
+      *[% target %]::meta = sub {
+        my $meta_code = do { local $/; <[% target %]::DATA> };
+        local $@;
+        my $meta = eval $meta_code;
+        die $@ if $@;
+        $meta;
+      };
     }
     use MooseX::Antlers::StealImport
       Moose => {
@@ -103,8 +112,12 @@ sub compiled_source {
       };
   };
 
-  my $postamble = strip q{
+  my $meta_construct = $self->_meta_construction_code($all_refs);
+
+  my $postamble = tt strip q{
     no MooseX::Antlers::StealImport qw(Moose);
+    __DATA__
+    [% meta_construct %]
   };
 
   my $compiled = join("\n", $preamble, $self->_raw_source, $postamble);
@@ -112,4 +125,33 @@ sub compiled_source {
   return $compiled;
 }
 
+sub _meta_construction_code {
+  my ($self, $all_refs) = @_;
+  my $target = $self->_target;
+  my $meta_obj = $target->meta;
+  my $mappings = {
+    %$all_refs,
+    map +(refaddr($target->can($_)) => '\&'.$target.'::'.$_),
+      $meta_obj->get_method_list, 'meta'
+  };
+  my $filter = RefFilter->new(
+    external_mappings => $mappings,
+    root_name => '$meta'
+  );
+  my $filtered_meta = Dumper($filter->visit($meta_obj));
+  my $meta_fixup = $filter->fixup_code;
+  my $target_string = perlstring($target);
+  return tt strip q{
+    require Moose;
+    my $meta = [% filtered_meta %];
+    [% meta_fixup %]
+    Class::MOP::store_metaclass_by_name([% target_string %] => $meta);
+    no warnings 'redefine';
+    *[% target %]::meta = sub {
+      Moose::Meta::Class->initialize( ref($_[0]) || $_[0] );
+    };
+    $meta;
+  };
+}
+
 1;
diff --git a/t/one.t b/t/one.t
index 5694a07..b789f65 100644
--- a/t/one.t
+++ b/t/one.t
@@ -5,9 +5,18 @@ use lib 't/lib';
 use Test::More;
 use Test::Exception;
 use Class::Unload;
+use IO::All;
+use Data::Dumper::Concise;
+use Data::Dump::Streamer;
 
 my $compiler = MooseX::Antlers::Compiler->load_with_compiler('One');
 
+sub dump_meta {
+  my $meta = $_[0];
+  local $meta->{methods}{meta};
+  join '', Dump($meta);
+}
+
 sub foo_called {
   &cmp_ok(One->get_called_foo, '==', @_); # cmp_ok has a $$$;$ proto
 }
@@ -35,11 +44,11 @@ sub test_One {
 
 my %orig_src = map +($_ => join '', Dump(One->can($_))), qw(new DESTROY foo);
 
-my $orig_foo_meta = Dump(One->meta);
+One->meta->get_method_list; # fill cache
 
-test_One();
+my $orig_meta = dump_meta One->meta;
 
-use Data::Dump::Streamer;
+test_One();
 
 my $compiled = $compiler->compiled_source;
 
@@ -48,11 +57,13 @@ my $compiled = $compiler->compiled_source;
 Class::Unload->unload('One');
 Class::MOP::remove_metaclass_by_name('One');
 
-eval "no warnings; $compiled";
+io('/tmp/One.pmc')->print($compiled);
 
-die "Shit. failed.\n\n${compiled}\n\nError: $@" if $@;
+require '/tmp/One.pmc';
 
-use Data::Dumper::Concise;
+#eval "no warnings; $compiled";
+
+#die "Shit. failed.\n\n${compiled}\n\nError: $@" if $@;
 
 my %compiled_src = map +($_ => join '', Dump(One->can($_))), qw(new DESTROY foo);
 
@@ -60,8 +71,15 @@ foreach my $method (qw(new DESTROY foo)) {
   is($compiled_src{$method}, $orig_src{$method}, "${method} restored ok");
 }
 
+my $compiled_meta = dump_meta One->meta;
+
 test_One;
 
+#io('orig')->print($orig_meta);
+#io('comp')->print($compiled_meta);
+
+is($orig_meta, $compiled_meta, 'metaclass restored ok');
+
 # write test_class method that checks method including call
 # Class::Unload One
 # build compiled source