File Coverage

lib/Devel/Trepan/Processor/Running.pm
Criterion Covered Total %
statement 35 110 31.8
branch 0 28 0.0
condition 0 3 0.0
subroutine 11 18 61.1
pod 0 8 0.0
total 46 167 27.5


line stmt bran cond sub pod time code
1             # -*- coding: utf-8 -*-
2             # Copyright (C) 2011-2012, 2014 Rocky Bernstein <rocky@cpan.org>
3 12     12   111 use strict; use warnings;
  12     12   29  
  12         504  
  12         86  
  12         26  
  12         541  
4 12     12   115 use rlib '../../..';
  12         30  
  12         86  
5              
6 12     12   8957 use Devel::Trepan::Position;
  12         64  
  12         455  
7              
8             package Devel::Trepan::Processor;
9 12     12   104 use English qw( -no_match_vars );
  12         43  
  12         115  
10              
11 12     12   3851 use constant SINGLE_STEPPING_EVENT => 1;
  12         39  
  12         801  
12 12     12   69 use constant NEXT_STEPPING_EVENT => 2;
  12         27  
  12         600  
13 12     12   75 use constant DEEP_RECURSION_EVENT => 4;
  12         33  
  12         592  
14 12     12   69 use constant RETURN_EVENT => 32;
  12         24  
  12         11899  
15              
16             sub continue($$) {
17 0     0 0 0 my ($self, $args) = @_;
18 0         0 $self->{skip_count} = -1;
19 0 0       0 if ($self->{settings}{traceprint}) {
20 0         0 $self->step();
21 0         0 return;
22             }
23 0 0       0 if (scalar @{$args} != 1) {
  0         0  
24             # Form is: "continue"
25             # my $(line_number, $condition, $negate) =
26             # $self->breakpoint_position($self->{proc}{cmd_argstr}, 0);
27             # return unless iseq && vm_offset;
28             # $bp = $self->.breakpoint_offset($condition, $negate, 1);
29             #return unless bp;
30 0         0 $self->{leave_cmd_loop} = $self->{dbgr}->cont($args->[1]);
31             } else {
32 0         0 $self->{leave_cmd_loop} = $self->{dbgr}->cont;
33             };
34 0 0       0 if ($self->{leave_cmd_loop}) {
35 0         0 $self->{DB_running} = 1;
36 0         0 $self->{DB_single} = 0;
37             }
38             }
39              
40             # sub quit(cmd='quit')
41             # {
42             # @next_level = 32000; # I'm guessing the stack size can't ever
43             # # reach this
44             # @next_thread = undef;
45             # @core.skip_count = -1; # No more event stepping
46             # @leave_cmd_loop = 1; # Break out of the processor command loop.
47             # @settings[:autoirb] = 0;
48             # @cmdloop_prehooks.delete_by_name('autoirb');
49             # @commands['quit'].run([cmd]);
50             # }
51              
52             sub parse_next_step_suffix($$)
53             {
54 0     0 0 0 my ($self, $step_cmd) = @_;
55 0         0 my $opts = {};
56 0         0 my $sigil = substr($step_cmd, -1);
57 0 0       0 if ('-' eq $sigil) {
    0          
    0          
58 0         0 $opts->{different_pos} = 0;
59             } elsif ('+' eq $sigil) {
60 0         0 $opts->{different_pos} = 1;
61             } elsif ('=' eq $sigil) {
62 0         0 $opts->{different_pos} = $self->{settings}{different};
63             # when ('!') { $opts->{stop_events} = {'raise' => 1} };
64             # when ('<') { $opts->{stop_events} = {'return' => 1}; }
65             # when ('>') {
66             # if (length($step_cmd) > 1 && substr($step_cmd, -2, 1) eq '<') {
67             # $opts->{stop_events} = {'return' => 1 };
68             # } else {
69             # $opts->{stop_events} = {'call' => 1; }
70             # }
71             # }
72             } else {
73 0         0 $opts->{different_pos} = $self->{settings}{different};
74             }
75 0         0 return $opts;
76             }
77              
78             # Does whatever setup needs to be done to set to ignore stepping
79             # to the finish of the current method.
80             sub finish($$) {
81 0     0 0 0 my ($self, $level_count) = @_;
82 0         0 $self->{leave_cmd_loop} = 1;
83 0         0 $self->{skip_count} = -1;
84 0         0 $self->{DB_running} = 1;
85 0         0 $self->{dbgr}->finish($level_count);
86             }
87              
88             sub next($$)
89             {
90 0     0 0 0 my ($self, $opts) = @_;
91 0         0 $self->{different_pos} = $opts->{different_pos};
92 0         0 $self->{leave_cmd_loop} = 1;
93             # NEXT_STEPPING_EVENT is sometimes broken.
94             # $self->{DB_single} = NEXT_STEPPING_EVENT;
95 0         0 $self->{next_level} = $self->{stack_size};
96 0         0 $self->{DB_single} = SINGLE_STEPPING_EVENT;
97 0         0 $self->{DB_running} = 1;
98             }
99              
100             sub step($$)
101             {
102 0     0 0 0 my ($self, $opts) = @_;
103 0         0 $self->{different_pos} = $opts->{different_pos};
104 0         0 $self->{leave_cmd_loop} = 1;
105 0         0 $self->{DB_single} = SINGLE_STEPPING_EVENT;
106 0         0 $self->{next_level} = 30000; # Virtually infinite
107 0         0 $self->{DB_running} = 1;
108             }
109              
110             sub running_initialize($)
111             {
112 13     13 0 45 my $self = shift;
113 13         92 $self->{stop_condition} = undef;
114 13         58 $self->{stop_events} = undef;
115 13         46 $self->{to_method} = undef;
116             $self->{last_pos} =
117 13         573 Devel::Trepan::Position->new(pkg => '', filename => '',
118             line =>'', event=>'');
119             }
120              
121             # Should we not stop here?
122             # Some reasons for skipping:
123             # - step count was given.
124             # - We want to make sure we stop on a different line
125             # - We want to stop only when some condition is reached (step until ...).
126             sub is_stepping_skip($)
127             {
128              
129 0     0 0   my $self = shift;
130 0 0         if ($self->{skip_count} < 0) {
    0          
131 0           return 1;
132             } elsif ($self->{skip_count} > 0) {
133 0           $self->{skip_count} --;
134 0           return 1
135             }
136              
137 0 0         if ($self->{settings}{'debugskip'}) {
138 0           $self->msg("diff: $self->{different_pos}, event : $self->{event}");
139 0           $self->msg("skip_count : $self->{skip_count}");
140             }
141              
142 0           my $frame = $self->{frame};
143              
144             my $new_pos = Devel::Trepan::Position->new(pkg => $frame->{pkg},
145             filename => $frame->{file},
146             line => $frame->{line},
147 0           event => $self->{event});
148              
149 0           my $skip_val = 0;
150              
151             # If the last stop was a breakpoint, don't stop again if we are at
152             # the same location with a line event.
153              
154 0           my $last_pos = $self->{last_pos};
155             # $skip_val ||= ($last_pos->event eq 'brkpt' && $self->{event} eq 'line');
156              
157 0 0         if ($self->{settings}{'debugskip'}) {
158 0           $self->msg("skip: $skip_val, last: $self->{last_pos}->inspect(), " .
159             "new: $new_pos->inspect()");
160             }
161              
162             # @last_pos[2] = new_pos[2] if 'nostack' eq $self->{different_pos};
163              
164 0           my $condition_met = 1;
165             # if (! $skip_val) {
166             # if (@stop_condition) {
167             # puts 'stop_cond' if @settings[:'debugskip'];
168             # debug_eval_no_errmsg(@stop_condition);
169             # } elsif (@to_method) {
170             # puts "method #{@frame.method} #{@to_method}" if
171             # $self->{setting}{'debugskip'};
172             # @frame.method == @to_method;
173             # } else {
174             # puts 'uncond' if $self->{settings}{'debugskip'};
175             # 1;
176             # };
177              
178             # $self->msg("condition_met: #{condition_met}, last: $self->{last_pos}, " .
179             # "new: $new_pos->inspect(), different #{@different_pos.inspect}") if
180             # $self->{settings}{'debugskip'};
181              
182             $skip_val = (($last_pos && $last_pos->eq($new_pos) && !!$self->{different_pos})
183 0   0       || !$condition_met);
184              
185 0           $self->{last_pos} = $new_pos;
186              
187 0 0         unless ($skip_val) {
188             # Set up the default values for the next time we consider
189             # skipping.
190 0           $self->{different_pos} = $self->{settings}{different};
191             }
192              
193 0           return $skip_val;
194             }
195              
196             sub restart_args($$) {
197 0     0 0   my $self = shift;
198 0           my @flags = ();
199             # If warn was on before, turn it on again.
200 12     12   109 no warnings 'once';
  12         28  
  12         3395  
201 0 0         push @flags, '-w' if $DB::ini_warn;
202              
203 0 0         if ($ENV{'TREPANPL_OPTS'}) {
204 0           my $opts = $Devel::Trepan::Core::invoke_opts;
205 0           foreach my $inc (@{$opts->{includes}}) {
  0            
206 0           push @flags, ('-I' . $inc);
207             }
208 0           foreach my $mod (@{$opts->{modules}}) {
  0            
209 0           push @flags, '-M' . $mod;
210             }
211             } else {
212             # Rebuild the -I flags that were on the initial
213             # command line.
214 0           for (@DB::ini_INC) {
215 0           push @flags, '-I', $_;
216             }
217             }
218              
219              
220             # Turn on taint if it was on before.
221 0 0         push @flags, '-T' if ${^TAINT};
222              
223             # Arrange for setting the old INC:
224             # Save the current @init_INC in the environment.
225 0           DB::set_list( "PERLDB_INC", @DB::ini_INC );
226              
227             ( $EXECUTABLE_NAME, @flags, '-d:Trepan', $DB::ini_dollar0,
228 0           @{$self->{dbgr}{exec_strs}},
  0            
229             @DB::ini_ARGV );
230             }
231              
232             1;