line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Devel::ebug::Plugin::StackTrace; |
2
|
|
|
|
|
|
|
|
3
|
19
|
|
|
19
|
|
10455
|
use strict; |
|
19
|
|
|
|
|
36
|
|
|
19
|
|
|
|
|
527
|
|
4
|
19
|
|
|
19
|
|
87
|
use warnings; |
|
19
|
|
|
|
|
28
|
|
|
19
|
|
|
|
|
479
|
|
5
|
19
|
|
|
19
|
|
90
|
use Scalar::Util qw(blessed); |
|
19
|
|
|
|
|
30
|
|
|
19
|
|
|
|
|
1062
|
|
6
|
19
|
|
|
19
|
|
101
|
use base qw(Exporter); |
|
19
|
|
|
|
|
30
|
|
|
19
|
|
|
|
|
17495
|
|
7
|
|
|
|
|
|
|
our @EXPORT = qw(stack_trace stack_trace_human stack_trace_human_args); |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
our $VERSION = '0.62_01'; # TRIAL VERSION |
10
|
|
|
|
|
|
|
$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval) |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
# return the stack trace |
13
|
|
|
|
|
|
|
sub stack_trace { |
14
|
16
|
|
|
16
|
0
|
102
|
my($self) = @_; |
15
|
16
|
|
|
|
|
126
|
my $response = $self->talk({ command => "stack_trace" }); |
16
|
16
|
50
|
|
|
|
62
|
return @{$response->{stack_trace}||[]}; |
|
16
|
|
|
|
|
133
|
|
17
|
|
|
|
|
|
|
} |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
# return the stack trace in a human-readable format |
20
|
|
|
|
|
|
|
sub stack_trace_human { |
21
|
14
|
|
|
14
|
0
|
5199
|
my($self) = @_; |
22
|
14
|
|
|
|
|
27
|
my @human; |
23
|
14
|
|
|
|
|
47
|
my @stack = $self->stack_trace; |
24
|
14
|
|
|
|
|
79
|
foreach my $frame (@stack) { |
25
|
15
|
|
|
|
|
131
|
my $subroutine = $frame->subroutine; |
26
|
15
|
|
|
|
|
133
|
my $package = $frame->package; |
27
|
15
|
|
|
|
|
137
|
my @args = $frame->args; |
28
|
15
|
|
|
|
|
169
|
my $first = $args[0]; |
29
|
15
|
|
|
|
|
42
|
my $first_class = ref($first); |
30
|
15
|
|
|
|
|
164
|
my($subroutine_class, $subroutine_method) = $subroutine =~ /^(.+)::([^:])+?$/; |
31
|
|
|
|
|
|
|
# warn "first: $first, first class: $first_class, package: $package, subroutine: $subroutine ($subroutine_class :: $subroutine_method)\n"; |
32
|
|
|
|
|
|
|
|
33
|
15
|
50
|
66
|
|
|
426
|
if (defined $first && blessed($first) && $subroutine =~ /^${first_class}::/ && |
|
|
50
|
33
|
|
|
|
|
|
|
100
|
33
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
66
|
|
|
|
|
34
|
|
|
|
|
|
|
$subroutine =~ /^$package/) { |
35
|
0
|
|
|
|
|
0
|
$subroutine =~ s/^${first_class}:://; |
36
|
0
|
|
|
|
|
0
|
shift @args; |
37
|
0
|
|
|
|
|
0
|
push @human, "\$self->$subroutine" . $self->stack_trace_human_args(@args); |
38
|
|
|
|
|
|
|
} elsif (defined $first && blessed($first) && $subroutine =~ /^${first_class}::/) { |
39
|
0
|
|
|
|
|
0
|
$subroutine =~ s/^${first_class}:://; |
40
|
0
|
|
|
|
|
0
|
shift @args; |
41
|
0
|
|
|
|
|
0
|
my($name) = $first_class =~ /([^:]+)$/; |
42
|
0
|
|
|
|
|
0
|
$first = '$' . lc($name); |
43
|
0
|
|
|
|
|
0
|
push @human, "$first->$subroutine" . $self->stack_trace_human_args(@args); |
44
|
|
|
|
|
|
|
} elsif ($subroutine =~ s/^${package}:://) { |
45
|
11
|
|
|
|
|
74
|
push @human, "$subroutine" . $self->stack_trace_human_args(@args); |
46
|
|
|
|
|
|
|
} elsif (defined $first && $subroutine_class eq $first) { |
47
|
1
|
|
|
|
|
3
|
shift @args; |
48
|
1
|
|
|
|
|
14
|
push @human, "$first->new" . $self->stack_trace_human_args(@args); |
49
|
|
|
|
|
|
|
} else { |
50
|
3
|
|
|
|
|
23
|
push @human, "$subroutine" . $self->stack_trace_human_args(@args); |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
} |
53
|
14
|
|
|
|
|
161
|
return @human; |
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
sub stack_trace_human_args { |
57
|
42
|
|
|
42
|
0
|
111
|
my($self, @args) = @_; |
58
|
42
|
|
|
|
|
114
|
foreach my $arg (@args) { |
59
|
40
|
100
|
|
|
|
327
|
if (not defined $arg) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
60
|
3
|
|
|
|
|
18
|
$arg = "undef"; |
61
|
|
|
|
|
|
|
} elsif (ref($arg) eq 'ARRAY') { |
62
|
1
|
|
|
|
|
4
|
$arg = "[...]"; |
63
|
|
|
|
|
|
|
} elsif (ref($arg) eq 'HASH') { |
64
|
1
|
|
|
|
|
3
|
$arg = "{...}"; |
65
|
|
|
|
|
|
|
} elsif (ref($arg)) { |
66
|
10
|
|
|
|
|
75
|
my($name) = ref($arg) =~ /([^:]+)$/; |
67
|
10
|
|
|
|
|
46
|
$arg = '$' . lc($name); |
68
|
|
|
|
|
|
|
} elsif ($arg =~ /^-?[\d.]+$/) { |
69
|
|
|
|
|
|
|
# number, do nothing |
70
|
|
|
|
|
|
|
} elsif ($arg =~ /^[\w:]*$/) { |
71
|
2
|
|
|
|
|
8
|
$arg =~ s/([\'\\])/\\$1/g; |
72
|
2
|
|
|
|
|
9
|
$arg = qq{'$arg'}; |
73
|
|
|
|
|
|
|
} else { |
74
|
9
|
|
|
|
|
29
|
$arg =~ s/([\'\\])/\\$1/g; |
75
|
9
|
|
|
|
|
60
|
$arg = qq{"$arg"}; |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
} |
78
|
42
|
|
|
|
|
214
|
return '(' . join(", ", @args) . ')'; |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
1; |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
__END__ |