File Coverage

lib/Devel/Trepan/CmdProcessor/Command/Set_Subcmd/Variable.pm
Criterion Covered Total %
statement 54 114 47.3
branch 0 24 0.0
condition n/a
subroutine 18 22 81.8
pod n/a
total 72 160 45.0


line stmt bran cond sub pod time code
1             # -*- coding: utf-8 -*-
2             # Copyright (C) 2011-2012, 2014-215 Rocky Bernstein <rocky@cpan.org>
3 12     12   108 use warnings; no warnings 'redefine';
  12     12   38  
  12     2   527  
  12     2   78  
  12         40  
  12         478  
  2         19  
  2         8  
  2         77  
  2         14  
  2         6  
  2         93  
4 12     12   82 use rlib '../../../../..';
  12     2   33  
  12         84  
  2         14  
  2         9  
  2         13  
5              
6             package Devel::Trepan::CmdProcessor::Command::Set::Variable;
7              
8 12     12   5487 use Devel::Trepan::CmdProcessor::Command::Subcmd::Core;
  12     2   34  
  12         402  
  2         1236  
  2         7  
  2         63  
9 12     12   72 use PadWalker qw(peek_our peek_my);
  12     2   33  
  12         926  
  2         15  
  2         4  
  2         137  
10              
11 12     12   79 use strict;
  12     2   32  
  12         399  
  2         11  
  2         4  
  2         44  
12 12     12   68 use vars qw(@ISA @SUBCMD_VARS);
  12     2   31  
  12         817  
  2         9  
  2         6  
  2         116  
13             @ISA = qw(Devel::Trepan::CmdProcessor::Command::Subcmd);
14             # Values inherited from parent
15 12     12   132 use vars @Devel::Trepan::CmdProcessor::Command::Subcmd::SUBCMD_VARS;
  12     2   39  
  12         4781  
  2         11  
  2         7  
  2         726  
16              
17             ## FIXME: do automatically.
18             our $CMD = "set variable";
19              
20             =pod
21              
22             =head2 Synopsis:
23              
24             =cut
25             our $HELP = <<'HELP';
26             =pod
27              
28             B<set variable> I<variable-name> = I<value>
29              
30             Set a I<my> or I<our> variable; I<value> must be a constant.
31              
32             =head2 Examples:
33              
34             set variable $foo = 20
35             set variable @ARY = (1,2,3)
36              
37             =head2 See also:
38              
39             L<C<eval>|Devel::Trepan::CmdProcessor::Command::Eval>
40              
41             =cut
42             HELP
43              
44             our $SHORT_HELP = "Set a 'my' or 'our' variable";
45              
46             our $MIN_ABBREV = length('var');
47             our $MIN_ARGS = 2;
48             our $MAX_ARGS = undef;
49             our $NEED_STACK = 1;
50              
51             sub set_var($$$)
52             {
53 0     0     my ($var_name, $ref, $value) = @_;
  0     0      
54 0           my $type = substr($var_name, 1, 1);
  0            
55 0 0         if ('$' eq $type) {
  0 0          
    0          
    0          
    0          
    0          
56 0           ${$ref->{$var_name}} = $value;
  0            
  0            
  0            
57             } elsif ('@' eq $type) {
58 0           @{$ref->{$var_name}} = @{$value};
  0            
  0            
  0            
  0            
  0            
59             } elsif ('%' eq $type) {
60 0           %{$ref->{$var_name}} = %{$value};
  0            
  0            
  0            
  0            
  0            
61             } else {
62 0           ${$ref->{$var_name}} = $value;
  0            
  0            
  0            
63             }
64             }
65              
66             sub run($$)
67             {
68 0     0     my ($self, $args) = @_;
  0     0      
69 0           my $proc = $self->{proc};
  0            
70 0           my @args = @$args;
  0            
71 0           shift @args; shift @args;
  0            
  0            
  0            
72              
73 0           my $var_name = shift @args;
  0            
74 0 0         shift @args if $args[0] eq '=';
  0 0          
75 0           my $value = join(' ', @args);
  0            
76              
77 0           my $i;
  0            
78 0           while (my ($pkg, $file, $line, $fn) = caller($i++)) { ; };
  0            
79 12     12   100 no warnings 'once';
  12     2   37  
  12         2644  
  2         15  
  2         8  
  2         462  
80 0           my $diff = $i - $DB::stack_depth;
  0            
81             # FIXME: 4 is a magic fixup constant, also found in DB::finish.
82             # Remove it.
83 0           my $our_hash = peek_our($diff + $proc->{frame_index} + 4);
  0            
84 0           my $my_hash = peek_my($diff + $proc->{frame_index} + 4);
  0            
85              
86 0 0         if (exists($my_hash->{$var_name})) {
  0 0          
    0          
    0          
87 0           set_var($var_name, $my_hash, $value);
  0            
88             } elsif (exists($our_hash->{$var_name})) {
89 0           set_var($var_name, $my_hash, $value);
  0            
90             } else {
91 0           $proc->errmsg("Can't find $var_name as a 'my' or 'our' variable");
  0            
92             }
93             }
94              
95             unless (caller) {
96             require Devel::Trepan;
97             # Demo it.
98             # FIXME: DRY with other subcommand manager demo code.
99             require Devel::Trepan::CmdProcessor::Mock;
100             my ($proc, $cmd) =
101             Devel::Trepan::CmdProcessor::Mock::subcmd_setup();
102             Devel::Trepan::CmdProcessor::Mock::subcmd_demo_info($proc, $cmd);
103             #my @args = (@{$cmd->{prefix}}, '$foo', '=', '20');
104             # $cmd->run(\@args);
105             }
106              
107             # Suppress a "used-once" warning;
108             $HELP || scalar @SUBCMD_VARS;