lib/Devel/REPL/Plugin/Commands.pm

   1 package Devel::REPL::Plugin::Commands;
   2
   3 use Devel::REPL::Plugin;
   4 use Scalar::Util qw(weaken);
   5
   6 use namespace::sweep;
   7 use vars qw($COMMAND_INSTALLER);
   8
   9 has 'command_set' => (
  10   is => 'ro', required => 1,
  11   lazy => 1, default => sub { {} }
  12 );
  13
  14 sub BEFORE_PLUGIN {
  15   my ($self) = @_;
  16   $self->load_plugin('Packages');
  17   unless ($self->can('setup_commands')) {
  18     my $pkg = ref $self || $self;
  19     no strict 'refs';
  20     *{"${pkg}::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