From: Matt S Trout <matthewt@hercule.scsys.co.uk>
Date: Sat, 5 Dec 2009 06:04:47 +0000 (+0000)
Subject: factor out compiler code
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5bd097e77c36517b6e983326120c5ced2c48d86b;p=gitmo%2FMooseX-Antlers.git

factor out compiler code
---

diff --git a/lib/MooseX/Antlers/Compiler.pm b/lib/MooseX/Antlers/Compiler.pm
new file mode 100644
index 0000000..0d9e437
--- /dev/null
+++ b/lib/MooseX/Antlers/Compiler.pm
@@ -0,0 +1,115 @@
+package MooseX::Antlers::Compiler;
+
+use Moose;
+use IO::All qw(io);
+use String::TT qw(strip tt);
+use B qw(perlstring);
+use aliased 'MooseX::Antlers::RefTracker';
+use aliased 'MooseX::Antlers::EvalTracker';
+use aliased 'MooseX::Antlers::RefFilter';
+
+has [ qw(_target _attr_refs _attr_et _im_et _raw_source) ] => (is => 'rw');
+
+sub load_with_compiler {
+  my ($class, $target) = @_;
+  $class->new->load($target);
+}
+
+sub load {
+  my ($self, $target) = @_;
+  my %attr_refs;
+  my %attr_et;
+  my $im_et;
+  my $orig_import = Moose->can('import');
+  no warnings 'redefine';
+  local *Moose::import = sub {
+    my $targ = caller;
+    Moose->$orig_import({ into => $targ });
+    my $has = $targ->can('has');
+    {
+      no strict 'refs';
+      *{"${targ}::has"} = sub {
+        $attr_refs{$_[0]} = [
+          map RefTracker->trace_refs( $_ => \@_ ),
+            '(\@_)', '$has_args{'.perlstring($_[0]).'}'
+        ];
+        my $et = EvalTracker->new->enable;
+        $has->(@_);
+        $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;
+  };
+  Class::MOP::load_class($target);
+  $self->_attr_refs(\%attr_refs);
+  $self->_attr_et(\%attr_et);
+  $self->_im_et($im_et);
+  $self->_target($target);
+  (my $pm_file = $target) =~ s/::/\//g;
+  $self->_raw_source(scalar io($INC{"${pm_file}.pm"})->slurp);
+  return $self;
+}
+
+sub compiled_source {
+  my ($self) = @_;
+  my %attr_et = %{$self->_attr_et};
+  my %attr_refs = %{$self->_attr_refs};
+  my $im_et = $self->_im_et;
+  my $target = $self->_target;
+  my %attr_construct;
+  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 %replay_has;
+    my %has_args;
+    BEGIN {
+      %replay_has = (
+  [% FOREACH a IN attr_construct_h %]
+        [% a.key %] => sub {
+          [% a.value %]
+        }
+  [% END %]
+      );
+    }
+    sub MooseX::Antlers::ImmutableHackFor::[% target %]::make_immutable {
+  [% im_construct %]
+    }
+    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::[% target %]' }
+      };
+  };
+
+  my $postamble = strip q{
+    no MooseX::Antlers::StealImport qw(Moose);
+  };
+
+  my $compiled = join("\n", $preamble, $self->_raw_source, $postamble);
+
+  return $compiled;
+}
+
+1;
diff --git a/t/one.t b/t/one.t
index aef210f..e308c44 100644
--- a/t/one.t
+++ b/t/one.t
@@ -1,51 +1,12 @@
 use strict;
 use warnings FATAL => 'all';
-use aliased 'MooseX::Antlers::EvalTracker';
-use aliased 'MooseX::Antlers::RefTracker';
-use aliased 'MooseX::Antlers::RefFilter';
-use B qw(perlstring);
+use MooseX::Antlers::Compiler;
 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_et;
-my $im_et;
-
-{
-  require Moose;
-  my $orig_import = Moose->can('import');
-  no warnings 'redefine';
-  local *Moose::import = sub {
-    my $targ = caller;
-    Moose->$orig_import({ into => $targ });
-    my $has = $targ->can('has');
-    {
-      no strict 'refs';
-      *{"${targ}::has"} = sub {
-        $attr_refs{$_[0]} = [
-          map RefTracker->trace_refs( $_ => \@_ ),
-            '(\@_)', '$has_args{'.perlstring($_[0]).'}'
-        ];
-        my $et = EvalTracker->new->enable;
-        $has->(@_);
-        $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;
-}
+
+my $compiler = MooseX::Antlers::Compiler->load_with_compiler('One');
 
 sub foo_called {
   &cmp_ok(One->get_called_foo, '==', @_); # cmp_ok has a $$$;$ proto
@@ -80,49 +41,7 @@ test_One();
 
 use Data::Dump::Streamer;
 
-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);
+my $compiled = $compiler->compiled_source;
 
 #warn $compiled; done_testing; exit 0;