# -*- coding: utf-8 -*-
# Copyright (C) 2011-2012, 2014-2015 Rocky Bernstein <rocky@cpan.org>
use warnings; no warnings 'redefine';
use rlib '../../../../..';
package Devel::Trepan::CmdProcessor::Command::Set::Return;
use Devel::Trepan::CmdProcessor::Command::Subcmd::Core;
use strict;
use vars qw(@ISA @SUBCMD_VARS);
@ISA = qw(Devel::Trepan::CmdProcessor::Command::Subcmd);
# Values inherited from parent
use vars @Devel::Trepan::CmdProcessor::Command::Subcmd::SUBCMD_VARS;
## FIXME: do automatically.
our $CMD = "set return";
=pod
=head2 Synopsis:
=cut
our $HELP = <<'HELP';
=pod
B<set return> I<return value>
Set the value about to be returned. This only works if you are stopped
at a return event.
=head2 See also:
L<C<show return>|Devel::Trepan::CmdProcessor::Command::Show::Return>
=cut
HELP
our $SHORT_HELP = "Set the value about to be returned";
our $MIN_ABBREV = length('ret');
our $MIN_ARGS = 1;
our $MAX_ARGS = 1;
our $NEED_STACK = 1;
use Data::Dumper;
sub run($$)
{
my ($self, $args) = @_;
my $proc = $self->{proc};
my @args = @$args;
shift @args;
no warnings 'once';
unless ($DB::event eq 'return') {
$proc->errmsg("We are not stopped at a return");
return;
}
my $ret_type = $proc->{dbgr}->return_type();
if ('undef' eq $ret_type) {
$proc->msg("Return value is <undef>");
} elsif ('array' eq $ret_type) {
# Not quite right, but we'll use this for now.
my @new_value = eval(join(' ', @args));
@DB::return_value = @new_value;
$proc->msg("Return array value set to:");
$proc->msg(Dumper(@new_value));
} elsif ('scalar' eq $ret_type) {
my $new_value = eval(join(' ', @args));
$DB::return_value = $new_value;
$proc->msg("Return value set to: $new_value");
}
}
unless (caller) {
# Demo it.
# FIXME: DRY with other subcommand manager demo code.
require Devel::Trepan::CmdProcessor::Mock;
my ($proc, $cmd) =
Devel::Trepan::CmdProcessor::Mock::subcmd_setup();
Devel::Trepan::CmdProcessor::Mock::subcmd_demo_info($proc, $cmd);
}
# Suppress a "used-once" warning;
$HELP || scalar @SUBCMD_VARS;