refactor formatting/printing shit, introduce error object for error_return

git-svn-id: http://dev.catalyst.perl.org/repos/bast/trunk/Devel-REPL@4323 bd8105ee-0ff8-0310-8827-fb3f25b6796d

diff --git a/lib/Devel/REPL.pm b/lib/Devel/REPL.pm
index a46fbbe..406cb42 100644 (file)
--- a/lib/Devel/REPL.pm
+++ b/lib/Devel/REPL.pm
@@ -9,6 +9,8 @@ our $VERSION = '1.002001'; # 1.2.1
 
 with 'MooseX::Object::Pluggable';
 
+use Devel::REPL::Error;
+
 has 'term' => (
   is => 'rw', required => 1,
   default => sub { Term::ReadLine->new('Perl REPL') }
@@ -26,26 +28,67 @@ has 'out_fh' => (
 
 sub run {
   my ($self) = @_;
-  while ($self->run_once) {
+  while ($self->run_once_safely) {
     # keep looping
   }
 }
 
+sub run_once_safely {
+  my ($self, @args) = @_;
+
+  my $ret = eval { $self->run_once(@args) };
+
+  if ($@) {
+    my $error = $@;
+    eval { $self->print("Error! - $error\n"); };
+    return 1;
+  } else {
+    return $ret;
+  }
+}
+
 sub run_once {
   my ($self) = @_;
+
   my $line = $self->read;
   return unless defined($line); # undefined value == EOF
-  my @ret = $self->eval($line);
-  eval {
-    $self->print(@ret);
-  };
-  if ($@) {
-    my $error = $@;
-    eval { $self->print("Error printing! - $error\n"); };
-  }
+
+  my @ret = $self->formatted_eval($line);
+
+  $self->print(@ret);
+
   return 1;
 }
 
+sub formatted_eval {
+  my ( $self, @args ) = @_;
+
+  my @ret = $self->eval(@args);
+
+  return $self->format(@ret);
+}
+
+sub format {
+  my ( $self, @stuff ) = @_;
+
+  if ( blessed($stuff[0]) and $stuff[0]->isa("Devel::REPL::Error") ) {
+    return $self->format_error(@stuff);
+  } else {
+    return $self->format_result(@stuff);
+  }
+}
+
+sub format_result {
+  my ( $self, @stuff ) = @_;
+
+  return @stuff;
+}
+
+sub format_error {
+  my ( $self, $error ) = @_;
+  return $error->stringify;
+}
+
 sub read {
   my ($self) = @_;
   return $self->term->readline($self->prompt);
@@ -60,15 +103,15 @@ sub eval {
 }
 
 sub compile {
-  my $_REPL = shift;
-  my $compiled = eval $_REPL->wrap_as_sub($_[0]);
+  my ( $_REPL, @args ) = @_;
+  my $compiled = eval $_REPL->wrap_as_sub(@args);
   return (undef, $_REPL->error_return("Compile error", $@)) if $@;
   return $compiled;
 }
 
 sub wrap_as_sub {
-  my ($self, $line) = @_;
-  return qq!sub {\n!.$self->mangle_line($line).qq!\n}\n!;
+  my ($self, $line, %args) = @_;
+  return qq!sub {\n!. ( $args{no_mangling} ? $line : $self->mangle_line($line) ).qq!\n}\n!;
 }
 
 sub mangle_line {
@@ -85,7 +128,7 @@ sub execute {
 
 sub error_return {
   my ($self, $type, $error) = @_;
-  return "${type}: ${error}";
+  return Devel::REPL::Error->new( type => $type, message => $error );
 }
 
 sub print {

diff --git a/lib/Devel/REPL/Plugin/Colors.pm b/lib/Devel/REPL/Plugin/Colors.pm
index 898437d..17592b8 100644 (file)
--- a/lib/Devel/REPL/Plugin/Colors.pm
+++ b/lib/Devel/REPL/Plugin/Colors.pm
@@ -14,7 +14,7 @@ has error_color => (
   default => 'bold red',
 );
 
-around error_return => sub {
+around format_error => sub {
   my $orig = shift;
   my $self = shift;
   return color($self->error_color)
@@ -23,12 +23,14 @@ around error_return => sub {
 };
 
 # we can't just munge @_ because that screws up DDS
-around print => sub {
+around format_result => sub {
   my $orig = shift;
   my $self = shift;
-  print {$self->out_fh} color($self->normal_color);
-  $orig->($self, @_);
-  print {$self->out_fh} color('reset');
+  return join "", (
+    color($self->normal_color),
+    $orig->($self, @_),
+    color('reset'),
+  );
 };
 
 # make arbitrary warns colored -- somewhat difficult because warn doesn't

diff --git a/lib/Devel/REPL/Plugin/DDS.pm b/lib/Devel/REPL/Plugin/DDS.pm
index 512d48c..457ec69 100644 (file)
--- a/lib/Devel/REPL/Plugin/DDS.pm
+++ b/lib/Devel/REPL/Plugin/DDS.pm
@@ -3,7 +3,7 @@ package Devel::REPL::Plugin::DDS;
 use Moose::Role;
 use Data::Dump::Streamer ();
 
-around 'print' => sub {
+around 'format_result' => sub {
   my $orig = shift;
   my $self = shift;
   my $to_dump = (@_ > 1) ? [@_] : $_[0];

diff --git a/lib/Devel/REPL/Plugin/Turtles.pm b/lib/Devel/REPL/Plugin/Turtles.pm
index 4ab7eab..8bcba92 100644 (file)
--- a/lib/Devel/REPL/Plugin/Turtles.pm
+++ b/lib/Devel/REPL/Plugin/Turtles.pm
@@ -1,26 +1,69 @@
 package Devel::REPL::Plugin::Turtles;
-use Moose::Role;
+use Devel::REPL::Plugin;
+
+use Scalar::Util qw(reftype);
+
+use MooseX::AttributeHelpers;
+
 use namespace::clean -except => [ 'meta' ];
 
-around 'eval' => sub {
+has default_command_prefix => (
+  isa => "RegexpRef",
+  is  => "rw",
+  default => sub { qr/\#/ },
+);
+
+has turtles_matchers => (
+  metaclass => "Collection::Array",
+  isa => "ArrayRef[RegexpRef|CodeRef]",
+  is  => "rw",
+  default => sub { my $prefix = shift->default_command_prefix; [qr/^ $prefix (\w+) \s* (.*) /x] },
+  provides => {
+    unshift => "add_turtles_matcher",
+  },
+);
+
+around 'formatted_eval' => sub {
   my $next = shift;
-  my ($self, $line) = @_;
-  if ( my ( $command, $rest ) = ( $line =~ /^#(\w+)\s*(.*)/ ) ) {
-    if ( my $cont = $self->can("continue_reading_if_necessary") ) {
-      $rest = $self->$cont($rest);
-    }
+  my ($self, $line, @args) = @_;
 
+  if ( my ( $command, @rest ) = $self->match_turtles($line) ) {
     my $method = "command_$command";
+    my $expr_method = "expr_$method";
 
-    if ( $self->can($method) ) {
-      return $self->$method($rest);
+    if ( my $expr_code = $self->can($expr_method) ) {
+      if ( my $read_more = $self->can("continue_reading_if_necessary") ) {
+        push @rest, $self->$read_more(pop @rest);
+      }
+      $self->$expr_code($next, @rest);
+    } elsif ( my $cmd_code = $self->can($method) ) {
+      return $self->$cmd_code($next, @rest);
     } else {
-      return $self->error_return("REPL error", "Command '$command' does not exist");
+      unless ( $line =~ /^\s*#/ ) { # special case for comments
+        return $self->format($self->error_return("REPL Error", "Command '$command' does not exist"));
+      }
     }
-  }
-  else {
-    return $next->($self, $line);
+  } else {
+    return $self->$next($line, @args);
   }
 };
 
+sub match_turtles {
+  my ( $self, $line ) = @_;
+
+  foreach my $thingy ( @{ $self->turtles_matchers } ) {
+    if ( reftype $thingy eq 'CODE' ) {
+      if ( my @res = $self->$thingy($line) ) {
+        return @res;
+      }
+    } else {
+      if ( my @res = ( $line =~ $thingy ) ) {
+        return @res;
+      }
+    }
+  }
+
+  return;
+}
+
 1;