line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Devel::hdb::TraceFollow; |
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
5
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
21
|
|
4
|
1
|
|
|
1
|
|
4
|
use warnings; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
26
|
|
5
|
|
|
|
|
|
|
|
6
|
1
|
|
|
1
|
|
5
|
use base 'Devel::Chitin'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
68
|
|
7
|
1
|
|
|
1
|
|
5
|
use IO::File; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
197
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
our $VERSION = '0.23_15'; |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
sub new { |
12
|
0
|
|
|
0
|
0
|
|
my($class, $file, $cb) = @_; |
13
|
|
|
|
|
|
|
|
14
|
0
|
|
|
|
|
|
my $self = { |
15
|
|
|
|
|
|
|
file => $file, |
16
|
|
|
|
|
|
|
cb => $cb, |
17
|
|
|
|
|
|
|
}; |
18
|
0
|
|
|
|
|
|
bless $self, $class; |
19
|
|
|
|
|
|
|
|
20
|
0
|
|
|
|
|
|
$self->attach(); |
21
|
|
|
|
|
|
|
} |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
sub init { |
24
|
0
|
|
|
0
|
1
|
|
my $self = shift; |
25
|
0
|
|
|
|
|
|
$self->_open_fh(); |
26
|
0
|
|
|
|
|
|
$self->trace(1); |
27
|
|
|
|
|
|
|
} |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
sub shutdown { |
30
|
0
|
|
|
0
|
0
|
|
my $self = shift; |
31
|
0
|
|
|
|
|
|
$self->trace(0); |
32
|
0
|
|
|
|
|
|
$self->detach(); |
33
|
|
|
|
|
|
|
} |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
BEGIN { |
36
|
1
|
|
|
1
|
|
7
|
no strict 'refs'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
152
|
|
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
# Accessors |
39
|
1
|
|
|
1
|
|
3
|
foreach my $acc( qw( file cb fh ) ) { |
40
|
3
|
|
|
|
|
10
|
*{$acc} = sub { |
41
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
42
|
0
|
0
|
|
|
|
0
|
if (@_) { |
43
|
0
|
|
|
|
|
0
|
$self->{$acc} = shift; |
44
|
|
|
|
|
|
|
} |
45
|
0
|
|
|
|
|
0
|
return $self->{$acc}; |
46
|
3
|
|
|
|
|
14
|
}; |
47
|
|
|
|
|
|
|
} |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
# Methods child classes must implement |
50
|
1
|
|
|
|
|
1
|
foreach my $acc ( qw(_open_fh notify_trace) ) { |
51
|
2
|
|
|
|
|
101
|
*{$acc} = sub { |
52
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
53
|
0
|
|
|
|
|
0
|
my $type = ref($self); |
54
|
0
|
|
|
|
|
0
|
die "$type did not implement ${acc}()"; |
55
|
2
|
|
|
|
|
5
|
}; |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
sub _line_offset_for_sub { |
60
|
0
|
|
|
0
|
|
|
my($self, $line, $subroutine) = @_; |
61
|
0
|
|
|
|
|
|
my $loc = $self->subroutine_location($subroutine); |
62
|
|
|
|
|
|
|
|
63
|
0
|
0
|
|
|
|
|
return $loc |
64
|
|
|
|
|
|
|
? $line - $loc->line |
65
|
|
|
|
|
|
|
: undef; |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
sub _line_from_sub_and_offset { |
69
|
0
|
|
|
0
|
|
|
my($self, $subroutine, $offset) = @_; |
70
|
0
|
|
|
|
|
|
my $loc = $self->subroutine_location($subroutine); |
71
|
|
|
|
|
|
|
|
72
|
0
|
0
|
|
|
|
|
return $loc |
73
|
|
|
|
|
|
|
? $loc->line + $offset |
74
|
|
|
|
|
|
|
: undef; |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
package Devel::hdb::Trace; |
78
|
1
|
|
|
1
|
|
5
|
use base 'Devel::hdb::TraceFollow'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
233
|
|
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
sub _open_fh { |
81
|
0
|
|
|
0
|
|
|
my $self = shift; |
82
|
0
|
|
0
|
|
|
|
my $fh = IO::File->new($self->file, 'w') |
83
|
|
|
|
|
|
|
|| die "Can't open ".$self->file." for writing trace file: $!"; |
84
|
0
|
|
|
|
|
|
$self->fh($fh); |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
sub notify_trace { |
88
|
0
|
|
|
0
|
|
|
my($self, $location) = @_; |
89
|
|
|
|
|
|
|
|
90
|
0
|
|
|
|
|
|
my $line = $location->line; |
91
|
0
|
|
|
|
|
|
my $subname = $location->subroutine; |
92
|
0
|
|
|
|
|
|
my $file = $location->filename; |
93
|
0
|
|
|
|
|
|
my $package = $location->package; |
94
|
|
|
|
|
|
|
|
95
|
0
|
|
|
|
|
|
my $loc_string; |
96
|
0
|
0
|
|
|
|
|
if (my $offset = $self->_line_offset_for_sub($line, $subname)) { |
97
|
0
|
|
|
|
|
|
$loc_string = "${subname}+${offset}"; |
98
|
|
|
|
|
|
|
} else { |
99
|
0
|
|
|
|
|
|
$loc_string = "${file}:${line}"; |
100
|
|
|
|
|
|
|
} |
101
|
0
|
|
0
|
|
|
|
$package ||= 'main'; |
102
|
0
|
|
|
|
|
|
$self->fh->print( join("\t", $loc_string, $package, $file, $line, $subname), "\n"); |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
sub notify_program_terminated { |
106
|
0
|
|
|
0
|
|
|
my $self = shift; |
107
|
0
|
|
|
|
|
|
$self->shutdown(); |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
package Devel::hdb::Follow; |
112
|
1
|
|
|
1
|
|
5
|
use base 'Devel::hdb::TraceFollow'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
391
|
|
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
sub _open_fh { |
115
|
0
|
|
|
0
|
|
|
my $self = shift; |
116
|
0
|
|
0
|
|
|
|
my $fh = IO::File->new($self->file, 'r') |
117
|
|
|
|
|
|
|
|| die "Can't open ".$self->file." for reading trace file: $!"; |
118
|
0
|
|
|
|
|
|
$self->fh($fh); |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
sub _next_trace_line { |
122
|
0
|
|
|
0
|
|
|
my $self = shift; |
123
|
0
|
|
|
|
|
|
return $self->fh->getline(); |
124
|
|
|
|
|
|
|
} |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
sub notify_trace { |
127
|
0
|
|
|
0
|
|
|
my($self, $at_location) = @_; |
128
|
|
|
|
|
|
|
|
129
|
0
|
|
|
|
|
|
my $at_line = $at_location->line; |
130
|
0
|
|
|
|
|
|
my $at_file = $at_location->filename; |
131
|
0
|
|
|
|
|
|
my $at_subname = $at_location->subroutine; |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
# The expected next location |
134
|
0
|
|
|
|
|
|
chomp(my $next_trace_line = $self->_next_trace_line); |
135
|
0
|
|
|
|
|
|
my($exp_location, $exp_package, $exp_file, $exp_line, $exp_subname) = split("\t", $next_trace_line); |
136
|
|
|
|
|
|
|
|
137
|
0
|
|
|
|
|
|
my $should_stop; |
138
|
0
|
0
|
|
|
|
|
if (my ($expected_sub, $expected_offset) = $exp_location =~ m/(.*)\+(\d+)$/) { |
|
|
0
|
|
|
|
|
|
139
|
0
|
|
|
|
|
|
my $offset = $self->_line_offset_for_sub($at_line, $at_subname); |
140
|
0
|
0
|
0
|
|
|
|
if ($expected_sub ne $at_subname or $expected_offset != $offset) { |
141
|
0
|
|
|
|
|
|
$should_stop = 1; |
142
|
0
|
|
|
|
|
|
$exp_line = $self->_line_from_sub_and_offset($expected_sub, $expected_offset); |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
} elsif( my($file, $line) = $exp_location =~ m/(.*):(\d+)$/) { |
146
|
0
|
|
0
|
|
|
|
$should_stop = ($file ne $at_file or $line != $at_line); |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
} else { |
149
|
0
|
|
|
|
|
|
warn "Trace file format unrecognized on line $.. First column does not look like a trace location"; |
150
|
|
|
|
|
|
|
} |
151
|
|
|
|
|
|
|
|
152
|
0
|
0
|
|
|
|
|
if ($should_stop) { |
153
|
0
|
|
|
|
|
|
my($package) = $at_subname =~ m/(.*)::(\w+)$/; |
154
|
0
|
|
0
|
|
|
|
$package ||= 'main'; |
155
|
0
|
|
0
|
|
|
|
my %diff_data = ( |
156
|
|
|
|
|
|
|
'package' => $package, |
157
|
|
|
|
|
|
|
filename => $at_file, |
158
|
|
|
|
|
|
|
line => $at_line, |
159
|
|
|
|
|
|
|
subroutine => $at_subname, |
160
|
|
|
|
|
|
|
sub_offset => $self->_line_offset_for_sub($at_line, $at_subname), |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
expected_package => $exp_package, |
163
|
|
|
|
|
|
|
expected_filename => $exp_file, |
164
|
|
|
|
|
|
|
expected_line => $exp_line, |
165
|
|
|
|
|
|
|
expected_subroutine => $exp_subname, |
166
|
|
|
|
|
|
|
expected_sub_offset => $self->_line_offset_for_sub($exp_line, $exp_subname) || '', |
167
|
|
|
|
|
|
|
); |
168
|
|
|
|
|
|
|
|
169
|
0
|
|
|
|
|
|
$self->cb->(\%diff_data); |
170
|
|
|
|
|
|
|
} |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
1; |