view release on metacpan or  search on metacpan

iperl  view on Meta::CPAN

use PadWalker 'peek_my';
use PPI;
use PPI::Find;
use Data::Dumper;
use Symbol;
use Term::ReadLine;
$App::REPL::DEBUG = 0;

{ my $in_package = 'App::REPL';
  sub in_package { @_ ? $in_package = shift : $in_package }
}

# ----------------------------------------------------------------------
# Added RESET as the color somehow bleeds into the prompt
# -- when we use Term::ReadLine
{ my $prompt;
  my $term = Term::ReadLine->new('iperl');
  sub pnew  { $prompt = RESET . in_package . ' _ ' }
  sub pcont { $prompt = RESET . in_package . '. ' }
  sub prompt {
    my $s = $term->readline($prompt);
    $term->addhistory($s) if defined($s) and $s =~ /\S/;
    $s
  }
  pnew;
  $term->ornaments(0)
}

sub eek { print STDERR BOLD RED @_, "\n"; goto REPL }


# ----------------------------------------------------------------------
# Magic.  This allows 'my' variables assigned within the eval to carry
# through subsequent evals -- unless the eval'd returns from the eval,
# in which case the next eval will get the same variables.
#--
use constant PRO_IN => <<'EOP';
  use App::REPL;
  use strict;
  no warnings 'void';
EOP
sub PRO {
  my $r = "no strict 'refs';\n"
        . "package @{[in_package]};\n";
  my $h = do { no strict 'refs'; ${in_package . '::REPL::env'} || {}};
  for (keys %$h) {
    /^(.)/;
    $r .= "my $_ = $1" . q,{${", . in_package . q,::REPL::env"}->, . "{'$_'}};\n"
  }
  $r . PRO_IN
}
use constant EPI => <<'EOE';
  ;
  no strict 'refs';
  for (Symbol::qualify('')) { s/::$//; main::in_package($_) }
  ${main::in_package . '::REPL::env'} = PadWalker::peek_my(0)
EOE

# ----------------------------------------------------------------------
# More magic.  This finds the final statement of some Perl, wherever
# that statement may be (even if its result cannot escape the overall
# evaluation), and saves its value in $App::REPL::ret
#--
$App::REPL::ret = '';
{ my $f = PPI::Find->new(sub { shift->isa('PPI::Statement') });
  sub save_ret {
    my $d = shift;
  
    # don't even try if it contains something troublesome.
    return $d->serialize if has_troublesome($d);
  
    my @s = $f->in($d);
    for (reverse @s) {
      next if within_constructor($_, $d);
      print Dumper $d if $App::REPL::DEBUG > 1;
      unshift @{$_->{children}},
        bless({content => '$App::REPL::ret'}, 'PPI::Token::Symbol'),
        bless({content => '='},               'PPI::Token::Operator');
      return $d->serialize
    }
  
    # try and save the whole thing
    return '$App::REPL::ret = ' . $d->serialize if @s;

    # give up
    $d->serialize
  }
}


{ my %troublesome = map { $_, 1 } qw(sub package use require my our local);
  my $f = PPI::Find->new(sub {
    return 0 unless (my $e = shift)->isa('PPI::Token::Word');
    return 1 if exists $troublesome{$e->{content}};
    0
  });
  sub has_troublesome { $f->in(shift) } 
}
  
sub dump_ret {
  return if ref $_[0] eq 'CODE';
  print BOLD CYAN Dumper $App::REPL::ret if $App::REPL::ret;
}

{ my $fc = PPI::Find->new(sub { $_[0]->isa('PPI::Structure::Constructor')
                             or $_[0]->isa('PPI::Structure::Block') });
  sub within_constructor {
    my ($s, $d) = @_;
    my $fs = PPI::Find->new(sub { shift eq $s });
    for ($fc->in($d)) {
      return 1 for $fs->in($_);
    }
    0
  }
}

# ----------------------------------------------------------------------
# The PPI here handles the rest of the magic: it detects unfinished
# blocks and such so that the repl can request more lines until they
# complete.  Note that this does -not- handle e.g. qw(
#--