File Coverage

lib/Devel/Trepan/CmdProcessor/Command/Set_Subcmd/Return.pm
Criterion Covered Total %
statement 54 88 61.3
branch 0 16 0.0
condition n/a
subroutine 18 20 90.0
pod n/a
total 72 124 58.0


line stmt bran cond sub pod time code
1             # -*- coding: utf-8 -*-
2             # Copyright (C) 2011-2012, 2014-2015 Rocky Bernstein <rocky@cpan.org>
3 12     12   111 use warnings; no warnings 'redefine';
  12     12   37  
  12     2   502  
  12     2   75  
  12         30  
  12         373  
  2         22  
  2         6  
  2         84  
  2         13  
  2         7  
  2         114  
4 12     12   70 use rlib '../../../../..';
  12     2   28  
  12         70  
  2         18  
  2         7  
  2         26  
5              
6             package Devel::Trepan::CmdProcessor::Command::Set::Return;
7              
8 12     12   5274 use Devel::Trepan::CmdProcessor::Command::Subcmd::Core;
  12     2   36  
  12         312  
  2         1162  
  2         6  
  2         58  
9              
10 12     12   66 use strict;
  12     2   31  
  12         318  
  2         14  
  2         6  
  2         62  
11 12     12   67 use vars qw(@ISA @SUBCMD_VARS);
  12     2   31  
  12         872  
  2         14  
  2         8  
  2         171  
12             @ISA = qw(Devel::Trepan::CmdProcessor::Command::Subcmd);
13             # Values inherited from parent
14 12     12   85 use vars @Devel::Trepan::CmdProcessor::Command::Subcmd::SUBCMD_VARS;
  12     2   36  
  12         2040  
  2         14  
  2         7  
  2         398  
15              
16             ## FIXME: do automatically.
17             our $CMD = "set return";
18              
19             =pod
20              
21             =head2 Synopsis:
22              
23             =cut
24             our $HELP = <<'HELP';
25             =pod
26              
27             B<set return> I<return value>
28              
29             Set the value about to be returned. This only works if you are stopped
30             at a return event.
31              
32             =head2 See also:
33              
34             L<C<show return>|Devel::Trepan::CmdProcessor::Command::Show::Return>
35              
36             =cut
37              
38             HELP
39              
40             our $SHORT_HELP = "Set the value about to be returned";
41              
42             our $MIN_ABBREV = length('ret');
43             our $MIN_ARGS = 1;
44             our $MAX_ARGS = 1;
45             our $NEED_STACK = 1;
46              
47 12     12   95 use Data::Dumper;
  12     2   31  
  12         1271  
  2         19  
  2         7  
  2         317  
48              
49             sub run($$)
50             {
51 0     0     my ($self, $args) = @_;
  0     0      
52 0           my $proc = $self->{proc};
  0            
53 0           my @args = @$args;
  0            
54 0           shift @args;
  0            
55 12     12   78 no warnings 'once';
  12     2   61  
  12         2929  
  2         21  
  2         8  
  2         634  
56 0 0         unless ($DB::event eq 'return') {
  0 0          
57 0           $proc->errmsg("We are not stopped at a return");
  0            
58 0           return;
  0            
59             }
60 0           my $ret_type = $proc->{dbgr}->return_type();
  0            
61 0 0         if ('undef' eq $ret_type) {
  0 0          
    0          
    0          
    0          
    0          
62 0           $proc->msg("Return value is <undef>");
  0            
63             } elsif ('array' eq $ret_type) {
64             # Not quite right, but we'll use this for now.
65 0           my @new_value = eval(join(' ', @args));
  0            
66 0           @DB::return_value = @new_value;
  0            
67 0           $proc->msg("Return array value set to:");
  0            
68 0           $proc->msg(Dumper(@new_value));
  0            
69             } elsif ('scalar' eq $ret_type) {
70 0           my $new_value = eval(join(' ', @args));
  0            
71 0           $DB::return_value = $new_value;
  0            
72 0           $proc->msg("Return value set to: $new_value");
  0            
73             }
74             }
75              
76             unless (caller) {
77             # Demo it.
78             # FIXME: DRY with other subcommand manager demo code.
79             require Devel::Trepan::CmdProcessor::Mock;
80             my ($proc, $cmd) =
81             Devel::Trepan::CmdProcessor::Mock::subcmd_setup();
82             Devel::Trepan::CmdProcessor::Mock::subcmd_demo_info($proc, $cmd);
83             }
84              
85             # Suppress a "used-once" warning;
86             $HELP || scalar @SUBCMD_VARS;