From: Matt S Trout <matthewt@hercule.scsys.co.uk>
Date: Sat, 5 Dec 2009 05:09:35 +0000 (+0000)
Subject: this, sort of, works
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=064721e6419bd56c5b9e34a70180a6e6f57eab85;p=gitmo%2FMooseX-Antlers.git

this, sort of, works
---

diff --git a/lib/MooseX/Antlers/EvalTracker.pm b/lib/MooseX/Antlers/EvalTracker.pm
index 8466698..d56a5aa 100644
--- a/lib/MooseX/Antlers/EvalTracker.pm
+++ b/lib/MooseX/Antlers/EvalTracker.pm
@@ -2,11 +2,14 @@ package MooseX::Antlers::EvalTracker;
 
 use Moose;
 use MooseX::Antlers::ErrorThrower;
+use aliased 'MooseX::Antlers::RefFilter';
 use Scalar::Util qw(weaken refaddr);
 use PadWalker qw(closed_over);
 use Sub::Identify qw(sub_fullname);
 use B qw(perlstring);
 use namespace::clean -except => 'meta';
+use String::TT qw(tt strip);
+use Data::Dumper::Concise;
 
 has '_original_eval_closure' => (is => 'ro', lazy_build => 1);
 has '_our_eval_closure' => (is => 'ro', lazy_build => 1);
@@ -71,6 +74,36 @@ sub _eval_closure_called_for {
   #warn Dumper($body);
 }
 
+sub serialized_construction {
+  my ($self, $externals) = @_;
+  my $code = strip q{
+    package Class::MOP::Method::Generated;
+    use strict;
+    use warnings;
+  };
+  foreach my $recorded (@{$self->recorded_coderefs}) {
+    my ($cr, $captures, $body) = @{$recorded};
+    my $name = sub_fullname($cr);
+    my $name_string = perlstring($name);
+    my $filter = RefFilter->new(
+      external_mappings => $externals,
+      root_name => '$__captures'
+    );
+    my $filtered_captures = Dumper($filter->visit($captures));
+    my $fixup_code = $filter->fixup_code;
+    my $use_captures = $self->_generate_capture_constructor($captures);
+    $code .= strip tt q{
+      {
+        my $__captures = [% filtered_captures %];
+        [% fixup_code %]
+        [% use_captures %]
+        *[% name %] = Sub::Name::subname [% name_string %] => [% body %];
+      }
+    };
+  }
+  return $code;
+}
+    
 sub _generate_coderef_constructor {
   my ($self, $entry) = @_;
   my ($cr, $captures, $body) = @{$entry};
diff --git a/lib/MooseX/Antlers/RefFilter.pm b/lib/MooseX/Antlers/RefFilter.pm
index 654bbc0..acfe798 100644
--- a/lib/MooseX/Antlers/RefFilter.pm
+++ b/lib/MooseX/Antlers/RefFilter.pm
@@ -121,7 +121,7 @@ sub _fixup_code_for_externals {
       # is an attempt to modify a readonly value and perl will burst into tears
       # $whatever = \"foo"
       # is ok so if the match succeeds switch it to that
-      if ($l =~ m/^\${(.*)}$/) { $l = $1; $r = "\\".$r; }
+      if ($l =~ m/^\${(.*)}$/) { $l = $1; $r = "\\(".$r.")"; }
       $l.' = '.$r.';';
     }
     sort keys %$ext
diff --git a/lib/MooseX/Antlers/StealImport.pm b/lib/MooseX/Antlers/StealImport.pm
new file mode 100644
index 0000000..b961452
--- /dev/null
+++ b/lib/MooseX/Antlers/StealImport.pm
@@ -0,0 +1,56 @@
+package MooseX::Antlers::StealImport;
+
+use strict;
+use warnings FATAL => 'all';
+
+my %saved_import;
+my %saved_inc;
+
+sub import {
+  my ($class, %steal_classes) = @_;
+  foreach my $to_steal (keys %steal_classes) {
+    (my $pm_file = $to_steal) =~ s/::/\//g;
+    if (exists $INC{"${pm_file}.pm"}) {
+      $saved_inc{$to_steal} = $INC{"${pm_file}.pm"}
+    }
+    $INC{"${pm_file}.pm"} = __FILE__;
+    my %steal_methods = %{$steal_classes{$to_steal}};
+    {
+      no strict 'refs';
+      no warnings 'redefine';
+      $saved_import{$to_steal} = $to_steal->can('import');
+      my $do = delete $steal_methods{-do};
+      *{"${to_steal}::import"} = sub {
+        my $targ = caller;
+        $do->(@_) if $do;
+        foreach my $meth (keys %steal_methods) {
+          *{"${targ}::${meth}"} = $steal_methods{$meth};
+        }
+      };
+    }
+  }
+}
+
+sub unimport {
+  my ($class, @unsteal_classes) = @_;
+  foreach my $unsteal (@unsteal_classes) {
+    if (exists $saved_inc{$unsteal}) {
+      (my $pm_file = $unsteal) =~ s/::/\//g;
+      $INC{"${pm_file}.pm"} = delete $saved_inc{$unsteal};
+    }
+    if (defined $saved_import{$unsteal}) {
+      {
+        no strict 'refs';
+        no warnings 'redefine';
+        *{"${unsteal}::import"} = delete $saved_import{$unsteal};
+      }
+    } else {
+      {
+        no strict 'refs';
+        delete ${"${unsteal}::"}{import};
+      }
+    }
+  }
+}
+
+1;
diff --git a/t/lib/One.pm b/t/lib/One.pm
index 519e901..8ffaf7f 100644
--- a/t/lib/One.pm
+++ b/t/lib/One.pm
@@ -8,4 +8,6 @@ sub get_called_foo { $called_foo }
 
 has foo => (is => 'rw', required => 1, trigger => sub { $called_foo++ });
 
+__PACKAGE__->meta->make_immutable;
+
 1;
diff --git a/t/one.t b/t/one.t
index eddb112..aef210f 100644
--- a/t/one.t
+++ b/t/one.t
@@ -6,39 +6,140 @@ use aliased 'MooseX::Antlers::RefFilter';
 use B qw(perlstring);
 use lib 't/lib';
 use Test::More;
+use Test::Exception;
+use Class::Unload;
+use String::TT qw(tt strip);
+use IO::All qw(io);
 
 my %attr_refs;
-my %attr_methods;
+my %attr_et;
+my $im_et;
 
 {
   require Moose;
-  my $orig = Moose->can('import');
+  my $orig_import = Moose->can('import');
   no warnings 'redefine';
   local *Moose::import = sub {
     my $targ = caller;
-    Moose->$orig({ into => $targ });
+    Moose->$orig_import({ into => $targ });
     my $has = $targ->can('has');
     {
       no strict 'refs';
       *{"${targ}::has"} = sub {
-        $attr_refs{$_[0]} = RefTracker->trace_refs(
-          '$attributes{'.perlstring($_[0]).'}'
-          => \@_
-        );
+        $attr_refs{$_[0]} = [
+          map RefTracker->trace_refs( $_ => \@_ ),
+            '(\@_)', '$has_args{'.perlstring($_[0]).'}'
+        ];
         my $et = EvalTracker->new->enable;
         $has->(@_);
-        $attr_methods{$_[0]} = $et->recorded_coderefs;
+        $attr_et{$_[0]} = $et->disable;
+        return;
       };
     }
   };
+  my $orig_immutable = Moose::Meta::Class->can('make_immutable');
+  local *Moose::Meta::Class::make_immutable = sub {
+    my $et = EvalTracker->new->enable;
+    $orig_immutable->(@_);
+    $im_et = $et->disable;
+    return;
+  };
   require One;
 }
 
-ok(One->can('foo'), 'foo accessor installed');
+sub foo_called {
+  &cmp_ok(One->get_called_foo, '==', @_); # cmp_ok has a $$$;$ proto
+}
+
+sub test_One {
+
+  ok(One->can('foo'), 'foo accessor installed');
+
+  dies_ok { One->new } 'foo is required';
+
+  foo_called(0 => 'trigger not called yet');
+
+  my $one = One->new(foo => 1);
+
+  foo_called(1 => 'trigger called once (constructor)');
+
+  cmp_ok($one->foo, '==', 1, 'read ok');
+
+  foo_called(1 => 'trigger not called for read');
+
+  $one->foo(2);
+
+  foo_called(2 => 'trigger called for setter');
+}
+
+my %orig_src = map +($_ => join '', Dump(One->can($_))), qw(new DESTROY one);
+
+my $orig_foo_meta = Dump(One->meta);
+
+test_One();
 
 use Data::Dump::Streamer;
 
-my $orig_foo_src = Dump(One->can('foo'));
+my $one_source_code = io($INC{'One.pm'})->all;
+
+#warn $attr_et{'foo'}->serialized_construction($attr_refs{'foo'});
+
+#my @has = (
+
+my $foo_build = $attr_et{'foo'}->serialized_construction($attr_refs{'foo'}[0]);
+
+my $im_build = $im_et->serialized_construction($attr_refs{'foo'}[1]);
+
+my $preamble = strip tt q{
+  my %replay_has;
+  my %has_args;
+  BEGIN {
+    %replay_has = (
+      foo => sub {
+        [% foo_build %]
+      }
+    );
+  }
+  sub MooseX::Antlers::ImmutableHackFor::Foo::make_immutable {
+[% im_build %]
+  }
+  use MooseX::Antlers::StealImport
+    Moose => {
+      -do => sub {
+        strict->import;
+        warnings->import;
+      },
+      has => sub {
+        $has_args{$_[0]} = \@_;
+        ($replay_has{$_[0]}||die "Can't find replay for $_[0]")
+          ->(@_);
+      },
+      meta => sub { 'MooseX::Antlers::ImmutableHackFor::Foo' }
+    };
+};
+
+my $postamble = strip q{
+  no MooseX::Antlers::StealImport qw(Moose);
+};
+
+my $compiled = join("\n", $preamble, $one_source_code, $postamble);
+
+#warn $compiled; done_testing; exit 0;
+
+Class::Unload->unload('One');
+Class::MOP::remove_metaclass_by_name('One');
+
+eval $compiled; die "Shit. failed.\n\n${compiled}\n\nError: $@" if $@;
+
+use Data::Dumper::Concise;
+
+my %compiled_src = map +($_ => join '', Dump(One->can($_))), qw(new DESTROY one);
+
+#foreach my $method (qw(new DESTROY one)) {
+#  is($compiled_src{$method}, $orig_src{$method}, "${method} restored ok");
+#}
+
+test_One;
 
 # write test_class method that checks method including call
 # Class::Unload One
@@ -46,9 +147,8 @@ my $orig_foo_src = Dump(One->can('foo'));
 # eval compiled source
 # run test_class after that as well as before unload
 
-use Data::Dumper::Concise;
-
 #warn Dumper \%attr_refs;
-#warn Dumper \%attr_methods;
+#warn Dumper \%attr_et;
+#warn Dumper $im_et;
 
 done_testing;