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