1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
package Devel::ebug::Plugin::StackTrace;
use strict;
use warnings;
use Scalar::Util qw(blessed);
use base qw(Exporter);
our @EXPORT = qw(stack_trace stack_trace_human stack_trace_human_args);
# return the stack trace
sub stack_trace {
my($self) = @_;
my $response = $self->talk({ command => "stack_trace" });
return @{$response->{stack_trace}||[]};
}
# return the stack trace in a human-readable format
sub stack_trace_human {
my($self) = @_;
my @human;
my @stack = $self->stack_trace;
foreach my $frame (@stack) {
my $subroutine = $frame->subroutine;
my $package = $frame->package;
my @args = $frame->args;
my $first = $args[0];
my $first_class = ref($first);
my($subroutine_class, $subroutine_method) = $subroutine =~ /^(.+)::([^:])+?$/;
# warn "first: $first, first class: $first_class, package: $package, subroutine: $subroutine ($subroutine_class :: $subroutine_method)\n";
if (defined $first && blessed($first) && $subroutine =~ /^${first_class}::/ &&
$subroutine =~ /^$package/) {
$subroutine =~ s/^${first_class}:://;
shift @args;
push @human, "\$self->$subroutine" . $self->stack_trace_human_args(@args);
} elsif (defined $first && blessed($first) && $subroutine =~ /^${first_class}::/) {
$subroutine =~ s/^${first_class}:://;
shift @args;
my($name) = $first_class =~ /([^:]+)$/;
$first = '$' . lc($name);
push @human, "$first->$subroutine" . $self->stack_trace_human_args(@args);
} elsif ($subroutine =~ s/^${package}:://) {
push @human, "$subroutine" . $self->stack_trace_human_args(@args);
} elsif (defined $first && $subroutine_class eq $first) {
shift @args;
push @human, "$first->new" . $self->stack_trace_human_args(@args);
} else {
push @human, "$subroutine" . $self->stack_trace_human_args(@args);
}
}
return @human;
}
sub stack_trace_human_args {
my($self, @args) = @_;
foreach my $arg (@args) {
if (not defined $arg) {
$arg = "undef";
} elsif (ref($arg) eq 'ARRAY') {
$arg = "[...]";
} elsif (ref($arg) eq 'HASH') {
$arg = "{...}";
} elsif (ref($arg)) {
my($name) = ref($arg) =~ /([^:]+)$/;
$arg = '$' . lc($name);
} elsif ($arg =~ /^-?[\d.]+$/) {
# number, do nothing
} elsif ($arg =~ /^[\w:]*$/) {
$arg =~ s/([\'\\])/\\$1/g;
$arg = qq{'$arg'};
} else {
$arg =~ s/([\'\\])/\\$1/g;
$arg = qq{"$arg"};
}
}
return '(' . join(", ", @args) . ')';
}
1;
|
