lib/Devel/REPL/Plugin/Commands.pm

   1 use strict;
   2 use warnings;
   3 package Devel::REPL::Plugin::Commands;
   4
   5 use Devel::REPL::Plugin;
   6 use Scalar::Util qw(weaken);
   7
   8 use namespace::autoclean;
   9 our $COMMAND_INSTALLER;
  10
  11 has 'command_set' => (
  12   is => 'ro',
  13   lazy => 1, default => sub { {} }
  14 );
  15
  16 sub BEFORE_PLUGIN {
  17   my ($self) = @_;
  18   $self->load_plugin('Packages');
  19   unless ($self->can('setup_commands')) {
  20     $self->meta->add_method('setup_commands' => sub {});
  21   }
  22 }
  23
  24 sub AFTER_PLUGIN {
  25   my ($self) = @_;
  26   $self->setup_commands;
  27 }
  28
  29 after 'setup_commands' => sub {
  30   my ($self) = @_;
  31   weaken($self);
  32   $self->command_set->{load_plugin} = sub {
  33     my $self = shift;
  34     sub { $self->load_plugin(@_); };
  35   };
  36 };
  37
  38 sub command_installer {
  39   my ($self) = @_;
  40   my $command_set = $self->command_set;
  41   my %command_subs = map {
  42     ($_ => $command_set->{$_}->($self));
  43   } keys %$command_set;
  44   return sub {
  45     my $package = shift;
  46     foreach my $command (keys %command_subs) {
  47       no strict 'refs';
  48       no warnings 'redefine';
  49       *{"${package}::${command}"} = $command_subs{$command};
  50     }
  51   };
  52 }
  53
  54 around 'mangle_line' => sub {
  55   my ($orig, $self) = (shift, shift);
  56   my ($line) = @_;
  57   my $name = '$'.__PACKAGE__.'::COMMAND_INSTALLER';
  58   return qq{BEGIN { ${name}->(__PACKAGE__) }\n}.$self->$orig(@_);
  59 };
  60
  61 around 'compile' => sub {
  62   my ($orig, $self) = (shift, shift);
  63   local $COMMAND_INSTALLER = $self->command_installer;
  64   $self->$orig(@_);
  65 };
  66
  67 1;
  68
  69 __END__
  70
  71 =head1 NAME
  72
  73 Devel::REPL::Plugin::Commands - Generic command creation plugin using injected functions
  74
  75 =cut
  76