Devel::REPL and Carp::REPL

Your applications are alive!

Shawn M Moore — sartak

Best Practical Solutions

REPL

• Read
• Eval
• Print
• Loop

Basis

$ re.pl
$ 1 + 1
2

$ map { $_ * $_ } 1 .. 4
$ARRAY1 = [
            1,
            4,
            9,
            16
          ];
    

LexEnv

$ my $x = 100;
100

$ $x + $x
200
    

Debugger

  DB<1> sub fact {
Missing right curly or square bracket
    

MultiLine::PPI

$ sub fact {
> my $n = shift;
> return 1 if $n > 2;
> return $n * fact($n - 1);
> }

$ fact 10
3628800
    

Colors

$ fact 15
    

Colors

$ fact 15
1307674368000

$ fact 100
Deep recursion on subroutine...
    

Colors

$ fact 15
1307674368000

$ fact 100
Deep recursion on subroutine...
9.33262154439441e+157
    

Timing

$ sum 1 .. 10000000
Took 2.44044303894043 seconds.
50000005000000
    

OutputCache

$ sum 1 .. 10000000
50000005000000

$ _ * 2
100000010000000

$ _ * 5
500000050000000
    

Completion (LexEnv)

$ my $doh_I_picked_a_very_long_name = "fool!";

$ length $doh_I_picked_a_very_long_name
    

Completion (Methods)

$ sub Class::doh_I_picked_a_very_long_name {...}

$ Class->doh_I_picked_a_very_long_name

$ my $obj = Class->new;

$ $obj->doh_I_picked_a_very_long_name
    

Completion (INC)

$ use D'oh::I::Picked::A::Very::Long::Name;
    

Nopaste

$ a("lot");
of work

$ that $you
want to

$ show $somebody
wow.

$ #nopaste
http://pastebin.com/wh4tarad3xample
    

$_REPL

$ $_REPL->load_plugin("Interrupt");
1

$ do_something while $x > 0;
Runtime error: Interrupted.

~/.re.pl/repl.rc

$_REPL->load_plugin($_) for qw(




);

~/.re.pl/repl.rc

$_REPL->load_plugin($_) for qw(
    ReadLineHistory       Colors
    FancyPrompt           Refresh
    Interrupt             OutputCache
    PPI                   Nopaste
);

~/.re.pl/repl.rc

use List::Util qw(                 );
    

~/.re.pl/repl.rc

use List::Util qw(reduce shuffle ...);
use List::MoreUtils ':all';
use Scalar::Util 'blessed', 'weaken';
use Scalar::Defer 'lazy', 'defer';

if (`pwd` =~ m{/work/}) {
    ...
}
    

Questions?

Answers?

Carp::REPL

• Devel::REPL
• $SIG{__DIE__}
• Devel::StackTrace::WithLexicals

Carp::REPL

• Devel::REPL
• $SIG{__DIE__}
• Devel::StackTrace::WithLexicals
• PadWalker
• Devel::LexAlias

Writing buggy script

sub print_zscore {





}

    

Writing buggy script

sub print_zscore {
    my $n = shift;
    my $d = int($n / 2);

    my $q = fact($n) / fact($d);
    print "$n!/$d! is $q";
}

print_zscore(10);
    

Running buggy script

$ perl zscore.pl
Illegal division by zero at zscore.pl line 15.
    

Carp::REPL on buggy script

$ perl -MCarp::REPL zscore.pl
Illegal division by zero at zscore.pl line 15.

Trace begun at zscore.pl line 15
main::print_zscore(10) called at zscore.pl
                              line 19

$
    

Look Around You

$ :l
File zscore.pl:

 10:
 11: sub print_zscore {
 12:     my $n = shift;
 13:     my $d = int($n / 2);
 14:
*15:     my $q = fact($n) / fact($d);
 16:     print "$n!/$d! is $q";
 17: }
 18:
 19: print_zscore(10);
 20:

Look Around You

$ :l
File zscore.pl:

 10:
 11: sub print_zscore {
 12:     my $n = shift;
 13:     my $d = int($n / 2);
 14:
*15:     my $q = fact($n) / fact($d);
 16:     print "$n!/$d! is $q";
 17: }
 18:
 19: print_zscore(10);
 20:

Poking around

*15:     my $q = fact($n) / fact($d);

$ $d
5

$ fact $d
0

Why you gotta be a busta, fact()?

$ \&fact
$CODE1 = sub {
           use warnings;
           use strict 'refs';
           my $n = shift @_;
           return 0 if $n < 2;
           $n * fact($n - 1);
         };

Eureka!

$ \&fact
$CODE1 = sub {
           use warnings;
           use strict 'refs';
           my $n = shift @_;
           return 0 if $n < 2;
           $n * fact($n - 1);
         };

Fixing fact

$ *fact = sub {
> my $n = shift;
> return 1 if $n < 2;
> return $n * fact($n - 1);
> };
Subroutine main::fact redefined
*main::fact

Carp::REPL on fixed script

$ $d
5

$ fact $d
120

$ fact($n)/fact($d)
30240

Carp::REPL on warnings

Use of uninitialized value in
numeric lt (<) at (eval 1090) line 1.

$ perl -MCarp::REPL=warn my-app.pl
    

Carp::REPL on test failures

$ perl -MCarp::REPL=test t/foo.t
    

Carp::REPL on demand

sub Application::bowels {
    # ...




    # ...
}
    

Carp::REPL on demand

sub Application::bowels {
    # ...
    if ($x eq '') {


    }
    # ...
}
    

Carp::REPL on demand

sub Application::bowels {
    # ...
    if ($x eq '') {
        require Carp::REPL;
        Carp::REPL::repl('$x is empty');
    }
    # ...
}
    

TAEB

Questions?

Answers?

Implementation

• Moose!
• Plugin = role
• Very hookable

Outline

• Loop: run
• Read: read
• Eval: formatted_eval
• Print: print

Loop

• run
  • run_once_safely
    • run_once

Read

• read

Eval

• formatted_eval
  • eval
    • compile
      • wrap_as_sub
        • mangle_line
    • execute
  • format
    • format_error
    • format_result

Print

• print

Timing

around eval => sub {









};
    

Timing

around eval => sub {
    my $orig = shift;
    my $self = shift;


    my $ret = $orig->$self(@_);



    return $ret;
};
    

Timing

around eval => sub {
    my $orig = shift;
    my $self = shift;

    my $start = time;
    my $ret = $orig->$self(@_);
    my $end = time;

    $self->print("Took ".($end - $start)."s");
    return $ret;
};
    

Colors: Attributes

has normal_color => (
    is      => 'rw',
    default => 'green',
    lazy    => 1,
);
    

Colors: Attributes

has error_color => (
    is      => 'rw',
    default => 'bold red',
    lazy    => 1,
);
    

Colors: Format Error

around format_error => sub {






};
    

Colors: Format Error

around format_error => sub {
    my $orig = shift;
    my $self = shift;

    return
           $orig->($self, @_)
                         ;
};
    

Colors: Format Error

around format_error => sub {
    my $orig = shift;
    my $self = shift;

    return color($self->error_color)
         . $orig->($self, @_)
         . color('reset');
};
    

Colors: Format Result

around format_result => sub {
    my $orig = shift;
    my $self = shift;

    return color($self->normal_color)
         . $orig->($self, @_)
         . color('reset');
};
    

Colors: Warnings

around 'compile', 'execute' => sub {






};
    

Colors: Warnings

around 'compile', 'execute' => sub {
    my $orig = shift;
    my $self = shift;



    $orig->($self, @_);
};
    

Colors: Warnings

around 'compile', 'execute' => sub {
    my $orig = shift;
    my $self = shift;

    local $SIG{__WARN__} = sub { ... };

    $orig->($self, @_);
};
    

Colors: Warnings

local $SIG{__WARN__} = sub {
    my $warning = shift;

    warn
         $warning
                       ;
};
    

Colors: Warnings

local $SIG{__WARN__} = sub {
    my $warning = shift;

    warn color($self->error_color)
       . $warning
       . color('reset');
};
    

OutputCache: sub _

sub foo {
    die "Got it!";
};

package Other;
foo();
    

OutputCache: sub _

sub _ {
    die "Got it!";
};

package Other;
_();
    

OutputCache

has output_cache => (
    is      => 'rw',
    isa     => 'ArrayRef',
    default => sub { [] },
    lazy    => 1,
);
    

OutputCache

around 'eval' => sub {
    my $orig = shift;
    my ($self, $line) = @_;



    my $ret = $orig->(@_);

    push @{ $self->output_cache }, $ret;
    return $ret;
};
    

OutputCache

around 'eval' => sub {
    my $orig = shift;
    my ($self, $line) = @_;

    local *_ = sub { $self->output_cache->[-1] };

    my $ret = $orig->(@_);

    push @{ $self->output_cache }, $ret;
    return $ret;
};
    

OutputCache's prototype

$ 2 * 4
8

$ _ + 1
8
    

OutputCache's prototype

_ + 1

_(+1)
    

OutputCache

around 'eval' => sub {
    my $orig = shift;
    my ($self, $line) = @_;

    local *_ = sub () { $self->output_cache->[-1] };

    my $ret = $orig->(@_);

    push @{ $self->output_cache }, $ret;
    return $ret;
};
    

LexEnv: lexical_environment

has lexical_environment => (
    is      => 'rw',
    isa     => 'Lexical::Persistence',
    lazy    => 1,
    default => sub { Lexical::Persistence->new },
);
    

LexEnv: mangle_line

around mangle_line => sub {
    my $orig = shift;
    my $self = shift;
    my $line = $orig->($self, @_);

    my $env = $self->lexical_environment;

    my $declarations =

           keys %{ $env->get_context('_') };

};
    

LexEnv: mangle_line

around mangle_line => sub {
    my $orig = shift;
    my $self = shift;
    my $line = $orig->($self, @_);

    my $env = $self->lexical_environment;

    my $declarations =
           map { "my $_;\n" }
           keys %{ $env->get_context('_') };

};
    

LexEnv: mangle_line

around mangle_line => sub {
    my $orig = shift;
    my $self = shift;
    my $line = $orig->($self, @_);

    my $env = $self->lexical_environment;

    my $declarations = join '',
           map { "my $_;\n" }
           keys %{ $env->get_context('_') };
    return $declarations . $line;
};
    

LexEnv: execute

around 'execute' => sub {
    my $orig = shift;
    my $self = shift;
    my $code = shift;

    my $env = $self->lexical_environment;
    my $wrapped = $env->wrap($code);

    return $orig->($self, $wrapped, @_);
};
    

Nopaste: complete_session

has complete_session => (
    is      => 'rw',
    isa     => 'Str',
    default => '',
    lazy    => 1,
);
    

Nopaste: quick!

around eval => sub {
    ...
};
    

Nopaste: command

sub command_nopaste {
    my $self = shift;






}
    

Nopaste: command

sub command_nopaste {
    my $self = shift;

    App::Nopaste->nopaste(



    );
}
    

Nopaste: command

sub command_nopaste {
    my $self = shift;

    App::Nopaste->nopaste(
        text => $self->complete_session,
        desc => "Devel::REPL session",
        lang => "perl",
    );
}
    

Turtles

around formatted_eval => sub {
    my $orig = shift;
    my ($self, $line, @rest) = @_;








    $orig->(@_);
};
    

Turtles

around formatted_eval => sub {
    my $orig = shift;
    my ($self, $line, @rest) = @_;

    if ($line =~ /^#\s*(\w+)$/) {




    }

    $orig->(@_);
};
    

Turtles

around formatted_eval => sub {
    my $orig = shift;
    my ($self, $line, @rest) = @_;

    if ($line =~ /^#\s*(\w+)$/) {
        my $command_method = "command_$1";
        if ($self->can($command_method)) {
            return $self->$command_method;
        }
    }

    $orig->(@_);
};
    

Questions?

Answers?

More info

• http://chainsawblues.vox.com/
• #devel-repl on irc.perl.org
• #moose on irc.perl.org