File Coverage

blib/lib/Devel/hdb/TraceFollow.pm
Criterion Covered Total %
statement 27 90 30.0
branch 0 16 0.0
condition 0 16 0.0
subroutine 8 21 38.1
pod 1 3 33.3
total 36 146 24.6


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;