lib/Devel/REPL.pm

   1 package Devel::REPL;
   2
   3 use Term::ReadLine;
   4 use Moose;
   5 use namespace::clean -except => [ 'meta' ];
   6 use 5.008001; # backwards compat, doesn't warn like 5.8.1
   7
   8 our $VERSION = '1.002001'; # 1.2.1
   9
  10 with 'MooseX::Object::Pluggable';
  11
  12 use Devel::REPL::Error;
  13
  14 has 'term' => (
  15   is => 'rw', required => 1,
  16   default => sub { Term::ReadLine->new('Perl REPL') }
  17 );
  18
  19 has 'prompt' => (
  20   is => 'rw', required => 1,
  21   default => sub { '$ ' }
  22 );
  23
  24 has 'out_fh' => (
  25   is => 'rw', required => 1, lazy => 1,
  26   default => sub { shift->term->OUT || \*STDOUT; }
  27 );
  28
  29 sub run {
  30   my ($self) = @_;
  31   while ($self->run_once_safely) {
  32     # keep looping
  33   }
  34 }
  35
  36 sub run_once_safely {
  37   my ($self, @args) = @_;
  38
  39   my $ret = eval { $self->run_once(@args) };
  40
  41   if ($@) {
  42     my $error = $@;
  43     eval { $self->print("Error! - $error\n"); };
  44     return 1;
  45   } else {
  46     return $ret;
  47   }
  48 }
  49
  50 sub run_once {
  51   my ($self) = @_;
  52
  53   my $line = $self->read;
  54   return unless defined($line); # undefined value == EOF
  55
  56   my @ret = $self->formatted_eval($line);
  57
  58   $self->print(@ret);
  59
  60   return 1;
  61 }
  62
  63 sub formatted_eval {
  64   my ( $self, @args ) = @_;
  65
  66   my @ret = $self->eval(@args);
  67
  68   return $self->format(@ret);
  69 }
  70
  71 sub format {
  72   my ( $self, @stuff ) = @_;
  73
  74   if ( $self->is_error($stuff[0]) ) {
  75     return $self->format_error(@stuff);
  76   } else {
  77     return $self->format_result(@stuff);
  78   }
  79 }
  80
  81 sub format_result {
  82   my ( $self, @stuff ) = @_;
  83
  84   return @stuff;
  85 }
  86
  87 sub format_error {
  88   my ( $self, $error ) = @_;
  89   return $error->stringify;
  90 }
  91
  92 sub is_error {
  93   my ( $self, $thingy ) = @_;
  94   blessed($thingy) and $thingy->isa("Devel::REPL::Error");
  95 }
  96
  97 sub read {
  98   my ($self) = @_;
  99   return $self->term->readline($self->prompt);
 100 }
 101
 102 sub eval {
 103   my ($self, $line) = @_;
 104   my $compiled = $self->compile($line);
 105   return $compiled unless defined($compiled) and not $self->is_error($compiled);
 106   return $self->execute($compiled);
 107 }
 108
 109 sub compile {
 110   my ( $_REPL, @args ) = @_;
 111   my $compiled = eval $_REPL->wrap_as_sub(@args);
 112   return $_REPL->error_return("Compile error", $@) if $@;
 113   return $compiled;
 114 }
 115
 116 sub wrap_as_sub {
 117   my ($self, $line, %args) = @_;
 118   return qq!sub {\n!. ( $args{no_mangling} ? $line : $self->mangle_line($line) ).qq!\n}\n!;
 119 }
 120
 121 sub mangle_line {
 122   my ($self, $line) = @_;
 123   return $line;
 124 }
 125
 126 sub execute {
 127   my ($self, $to_exec, @args) = @_;
 128   my @ret = eval { $to_exec->(@args) };
 129   return $self->error_return("Runtime error", $@) if $@;
 130   return @ret;
 131 }
 132
 133 sub error_return {
 134   my ($self, $type, $error) = @_;
 135   return Devel::REPL::Error->new( type => $type, message => $error );
 136 }
 137
 138 sub print {
 139   my ($self, @ret) = @_;
 140   my $fh = $self->out_fh;
 141   no warnings 'uninitialized';
 142   print $fh "@ret";
 143   print $fh "\n" if $self->term->ReadLine =~ /Gnu/;
 144 }
 145
 146 =head1 NAME
 147
 148 Devel::REPL - a modern perl interactive shell
 149
 150 =head1 SYNOPSIS
 151
 152   my $repl = Devel::REPL->new;
 153   $repl->load_plugin($_) for qw(History LexEnv);
 154   $repl->run
 155
 156 Alternatively, use the 're.pl' script installed with the distribution
 157
 158   system$ re.pl
 159
 160 =head1 AUTHOR
 161
 162 Matt S Trout - mst (at) shadowcatsystems.co.uk (L<http://www.shadowcatsystems.co.uk/>)
 163
 164 =head1 CONTRIBUTORS
 165
 166 =over 4
 167
 168 =item Stevan Little - stevan (at) iinteractive.com
 169
 170 =item Alexis Sukrieh - sukria+perl (at) sukria.net
 171
 172 =item epitaph
 173
 174 =item mgrimes - mgrimes (at) cpan dot org
 175
 176 =item Shawn M Moore - sartak (at) gmail.com
 177
 178 =back
 179
 180 =head1 LICENSE
 181
 182 This library is free software under the same terms as perl itself
 183
 184 =cut
 185
 186 1;