X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMooseX-Antlers.git;a=blobdiff_plain;f=lib%2FMooseX%2FAntlers%2FDevelDeclareHandler.pm;fp=lib%2FMooseX%2FAntlers%2FDevelDeclareHandler.pm;h=509670334af021a8c5a22723c7fdfb9f5d0a95ff;hp=0000000000000000000000000000000000000000;hb=48972854790a1af6ed892edad6d761f8da2bef3d;hpb=fec6319b820dc7f7890a2516b10ff99bfb8bda0b

diff --git a/lib/MooseX/Antlers/DevelDeclareHandler.pm b/lib/MooseX/Antlers/DevelDeclareHandler.pm
new file mode 100644
index 0000000..5096703
--- /dev/null
+++ b/lib/MooseX/Antlers/DevelDeclareHandler.pm
@@ -0,0 +1,63 @@
+package MooseX::Antlers::DevelDeclareHandler;
+
+use Method::Signatures::Simple ();
+use B::Compiling;
+use B::Hooks::EndOfScope;
+
+my %fix;
+my %names;
+
+my $orig_block = Devel::Declare::Context::Simple->can('inject_if_block');
+
+*Devel::Declare::Context::Simple::inject_if_block = sub {
+  $orig_block->(@_);
+  my $line = $_[0]->get_linestr;
+  $line =~ s/BEGIN {.*?};//;
+  push(@{$fix{PL_compiling->file}}, [ PL_compiling->line, $line ]);
+};
+
+my $orig_scope = Devel::Declare::Context::Simple->can('inject_scope');
+
+*Devel::Declare::Context::Simple::inject_scope = sub {
+  my $self = $_[0];
+  $orig_scope->(@_);
+  on_scope_end {
+    push(@{$fix{PL_compiling->file}}, [ PL_compiling->line, $self->get_linestr ]);
+  };
+};
+
+my $orig_install = Devel::Declare::MethodInstaller::Simple->can('install');
+
+*Devel::Declare::MethodInstaller::Simple::install = sub {
+  push(@{$names{PL_compiling->file}}, $_[1]);
+  $orig_install->(@_);
+};
+
+sub emit_result {
+  my ($file) = @_;
+  use IO::All qw(io);
+  my @self = io($file)->getlines;
+  my @methods = @{$names{$file}};
+  my $method_section = q!
+use Sub::Name ();
+my ($meth, @methods);
+BEGIN {
+  my @methods = qw(!.join(' ', @methods).q!);
+  $meth = sub (&) {
+    my $name = shift(@methods);
+    *$name = Sub::Name::subname $name => $_[0];
+  };
+}
+use MooseX::Antlers::StealImport
+  'Method::Signatures::Simple' => {
+    method => $meth
+  };
+!;
+  foreach my $f (@{$fix{$file}}) {
+    my ($line, $linestr) = @$f;
+    $self[$line-1] = $linestr;
+  }
+  return join("", $method_section, @self);
+}
+
+1;