view release on metacpan or  search on metacpan

lib/Devel/hdb/App/Eval.pm  view on Meta::CPAN

package Devel::hdb::App::Eval;

use strict;
use warnings;

use Data::Transform::ExplicitMetadata qw(encode);

use base 'Devel::hdb::App::Base';

use Devel::hdb::Utils;

our $VERSION = '0.25';

__PACKAGE__->add_route('post', '/eval', \&do_eval);
__PACKAGE__->add_route('get', qr{/getvar/(\d+)/([^/]+)}, \&do_getvar);
__PACKAGE__->add_route('get', qr{/getvar/(\d+)}, \&list_vars_at_level);

# Evaluate some expression in the debugged program's context.
# It works because when string-eval is used, and it's run from
# inside package DB, then magic happens where it's evaluate in
# the first non-DB-package call frame.
# We're setting up a long_call so we can return back from all the
# web-handler code (which are non-DB packages) before actually
# evaluating the string.
sub do_eval {
    my($class, $app, $env) = @_;

    my $body = $class->_read_request_body($env);
    my $params = $app->decode_json($body);
    my $eval_string = Devel::hdb::Utils::_fixup_expr_for_eval($params->{code});

    return _eval_plumbing_closure($app, $env, $eval_string, $params->{wantarray});
}

my %perl_special_vars = map { $_ => 1 }
    qw( $0 $1 $2 $3 $4 $5 $6 $7 $8 $9 $& ${^MATCH} $` ${^PREMATCH} $'
        ${^POSTMATCH} $+ $^N @+ %+ $. $/ $| $\ $" $; $% $= $- @-
        %- $~ $^ $: $^L $^A $? ${^CHILD_ERROR_NATIVE} ${^ENCODING}
        $! %! $^E $@ $$ $< $> $[ $] $^C $^D ${^RE_DEBUG_FLAGS}
        ${^RE_TRIE_MAXBUF} $^F $^H %^H $^I $^M $^O ${^OPEN} $^P $^R
        $^S $^T ${^TAINT} ${^UNICODE} ${^UTF8CACHE} ${^UTF8LOCALE}
        $^V $^W ${^WARNING_BITS} ${^WIN32_SLOPPY_STAT} $^X @ARGV $ARGV
        @F  @ARG ); # @_ );
$perl_special_vars{q{$,}} = 1;
$perl_special_vars{q{$(}} = 1;
$perl_special_vars{q{$)}} = 1;

# Get the value of a variable, possibly in an upper stack frame
sub do_getvar {
    my($class, $app, $env, $level, $varname) = @_;

    if ($perl_special_vars{$varname}) {
        my $wantarray = substr($varname, 0, 1) eq '$' ? 0 : 1;
        return _eval_plumbing_closure($app, $env, $varname, $wantarray);
    }

    my $value = eval { $app->get_var_at_level($varname, $level) };
    my $exception = $@;

    if ($exception) {
        if ($exception =~ m/Can't locate PadWalker/) {
            return [ 501,
                    [ 'Content-Type' => 'text/html'],
                    [ 'Not implemented - PadWalker module is not available'] ];

        } elsif ($exception =~ m/Not nested deeply enough/) {
            return [ 404,
                    [ 'Content-Type' => 'text/html' ],
                    [ 'Stack level not found' ] ];
        } else {
            die $exception
        }
    }

    my $result = Data::Transform::ExplicitMetadata::encode($value);
    return [ 200,
            [ 'Content-Type' => 'application/json' ],
            [ $app->encode_json($result) ]
        ];
}

sub _eval_plumbing_closure {
    my($app, $env, $eval_string, $wantarray) = @_;

    $eval_string = Devel::hdb::Utils::_fixup_expr_for_eval($eval_string);
    return sub {
        my $responder = shift;
        $env->{'psgix.harakiri.commit'} = Plack::Util::TRUE;

        $app->eval(
            $eval_string,
            $wantarray,
            sub {
                my($eval_result, $exception) = @_;

                my $result = Data::Transform::ExplicitMetadata::encode($exception || $eval_result);
                $responder->([ $exception ? 409 : 200,
                                [ 'Content-Type' => 'application/json' ],
                                [ $app->encode_json($result) ]]);
            }
        );
    };
}

1;

=pod

=head1 NAME

Devel::hdb::App::Eval - Evaluate data in the debugged program's context

=head1 DESCRIPTION

Registers routes for evaluating arbitrary Perl code and for inspecting
variables in the debugged program.

=head2 Routes

=over 4

=item POST /eval

Evaluate a string of Perl code in the context of the debugged process.