lib/Devel/REPL.pm

   1 package Devel::REPL;
   2
   3 use Term::ReadLine;
   4 use Moose;
   5 use namespace::clean -except => [ 'meta' ];
   6
   7 with 'MooseX::Object::Pluggable';
   8
   9 has 'term' => (
  10   is => 'rw', required => 1,
  11   default => sub { Term::ReadLine->new('Perl REPL') }
  12 );
  13
  14 has 'prompt' => (
  15   is => 'rw', required => 1,
  16   default => sub { '$ ' }
  17 );
  18
  19 has 'out_fh' => (
  20   is => 'rw', required => 1, lazy => 1,
  21   default => sub { shift->term->OUT || \*STDOUT; }
  22 );
  23
  24 sub run {
  25   my ($self) = @_;
  26   while ($self->run_once) {
  27     # keep looping
  28   }
  29 }
  30
  31 sub run_once {
  32   my ($self) = @_;
  33   my $line = $self->read;
  34   return unless defined($line); # undefined value == EOF
  35   my @ret = $self->eval($line);
  36   $self->print(@ret);
  37   return 1;
  38 }
  39
  40 sub read {
  41   my ($self) = @_;
  42   return $self->term->readline($self->prompt);
  43 }
  44
  45 sub eval {
  46   my ($self, $line) = @_;
  47   my ($to_exec, @rest) = $self->compile($line);
  48   return @rest unless defined($to_exec);
  49   my @ret = $self->execute($to_exec);
  50   return @ret;
  51 }
  52
  53 sub compile {
  54   my $_REPL = shift;
  55   my $compiled = eval $_REPL->wrap_as_sub($_[0]);
  56   return (undef, $_REPL->error_return("Compile error", $@)) if $@;
  57   return $compiled;
  58 }
  59
  60 sub wrap_as_sub {
  61   my ($self, $line) = @_;
  62   return qq!sub {\n!.$self->mangle_line($line).qq!\n}\n!;
  63 }
  64
  65 sub mangle_line {
  66   my ($self, $line) = @_;
  67   return $line;
  68 }
  69
  70 sub execute {
  71   my ($self, $to_exec, @args) = @_;
  72   my @ret = eval { $to_exec->(@args) };
  73   return $self->error_return("Runtime error", $@) if $@;
  74   return @ret;
  75 }
  76
  77 sub error_return {
  78   my ($self, $type, $error) = @_;
  79   return "${type}: ${error}";
  80 }
  81
  82 sub print {
  83   my ($self, @ret) = @_;
  84   my $fh = $self->out_fh;
  85   print $fh "@ret";
  86 }
  87
  88 1;