# -*- 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;