File Coverage

lib/Devel/Trepan/Core.pm
Criterion Covered Total %
statement 92 161 57.1
branch 14 52 26.9
condition 7 19 36.8
subroutine 21 31 67.7
pod 2 8 25.0
total 136 271 50.1


line stmt bran cond sub pod time code
1             # -*- coding: utf-8 -*-
2             # Copyright (C) 2011-2014 Rocky Bernstein <rocky@cpan.org>
3             # Top-level require that pulls in the rest of the debugger.
4             # It's also the thing that gets called from DB:: hooks
5              
6 2     2   1346 use warnings; use utf8;
  2     2   5  
  2         70  
  2         1202  
  2         30  
  2         10  
7             # FIXME: Can't use strict;
8              
9             package Devel::Trepan::Core;
10              
11             # Something in the require process munges $0 into 'trepan.pl'.
12             # To make matters more sensitive, Enbugger processes $0 special
13             # to make it debuggable. Thereore...
14             # save and restore $0.
15             my $dollar0_save;
16             BEGIN {
17 2     2   136 $dollar0_save = $0;
18             }
19              
20 2     2   13 use rlib '.';
  2         5  
  2         16  
21 2     2   1641 use Devel::Trepan::DB;
  2         9  
  2         80  
22 2     2   743 use Devel::Trepan::DB::Use;
  2         5  
  2         53  
23 2     2   10 use Devel::Trepan::DB::LineCache; # for remap_e_string_to_file();
  2         5  
  2         345  
24 2     2   20 use Devel::Trepan::CmdProcessor;
  2         5  
  2         271  
25 2     2   777 use Devel::Trepan::SigHandler;
  2         7  
  2         65  
26 2     2   670 use Devel::Trepan::WatchMgr;
  2         6  
  2         53  
27 2     2   14 use Devel::Trepan::IO::Output;
  2         5  
  2         40  
28 2     2   672 use Devel::Trepan::Interface::Script;
  2         5  
  2         80  
29 2     2   720 use Devel::Trepan::Interface::Server;
  2         8  
  2         133  
30 2     2   23 use Devel::Trepan::Util;
  2         6  
  2         250  
31             # print join(', ', @INC, "\n");
32              
33 2     2   14 use vars qw(@ISA $dbgr $invoke_opts);
  2         5  
  2         115  
34              
35 2 50   2   11 use constant HAVE_BULLWINKLE => eval q(use Devel::Trepan::BWProcessors; 1) ? 1 : 0;
  2     2   5  
  2         109  
  2         190  
  0         0  
  0         0  
36              
37              
38             @ISA = qw(DB);
39              
40             sub add_startup_files($$;$) {
41 0     0 0 0 my ($cmdproc, $startup_file, $nowarn) = @_;
42 0         0 my $errmsg = Devel::Trepan::Util::invalid_filename($startup_file);
43 0 0       0 if ($errmsg) {
44 0 0       0 print STDERR "${errmsg}.\n" unless $nowarn;
45             } else {
46 0         0 push @{$cmdproc->{cmd_queue}}, "source $startup_file";
  0         0  
47             }
48             }
49              
50             sub new {
51 3     3 0 726 my $class = shift;
52 3         285 my %ORIG_SIG = %SIG; # Makes a copy of %SIG;
53 3         55 my $self = {
54             watch => Devel::Trepan::WatchMgr->new(), # List of watch expressions
55             orig_sig => \%ORIG_SIG,
56             caught_signal => 0,
57             exec_strs => [],
58             need_e_remap => 0
59             };
60 3         11 bless $self, $class;
61 3         16 $self->awaken();
62 3         57 $self->skippkg('Devel::Trepan::Core');
63 3         18 $self->skippkg('Devel::Trepan::DB::Use');
64 3         16 $self->skippkg('SelfLoader');
65 3         31 $self->register();
66 3         27 $self->ready();
67 3         32 return $self;
68             }
69              
70             # Called when debugger is ready for reading commands. Main
71             # entry point.
72             sub idle($$$)
73             {
74 0     0 1 0 my ($self, $event, $args) = @_;
75 0         0 my $proc = $self->{proc};
76 0 0       0 $event = 'terminated' if $DB::package eq 'Devel::Trepan::Terminated';
77 0 0 0     0 if ($self->{need_e_remap} && $DB::filename eq '-e') {
78 0         0 remap_dbline_to_file();
79 0         0 $self->{need_e_remap} = 0;
80             }
81              
82 0         0 $proc->process_commands($DB::caller, $event, $args);
83 0         0 $self->{caught_signal} = 0;
84             }
85              
86             # Called on catching a signal that SigHandler says
87             # we should enter the debugger for. That it there is 'stop'
88             # set on that signal.
89             sub signal_handler($$$)
90             {
91 0     0 0 0 my ($self, $signame) = @_;
92 0         0 $DB::running = 0;
93 0         0 $DB::step = 0;
94 0         0 $DB::caller = [caller(1)];
95             ($DB::package, $DB::filename, $DB::lineno, $DB::subroutine, $DB::hasargs,
96             $DB::wantarray, $DB::evaltext, $DB::is_require, $DB::hints, $DB::bitmask,
97             $DB::hinthash
98 0         0 ) = @{$DB::caller};
  0         0  
99 0         0 my $proc = $self->{proc};
100 0         0 $self->{caught_signal} = 1;
101 0         0 $DB::signal |= 2;
102             }
103              
104             sub output($)
105             {
106 0     0 1 0 my ($self, $msg) = @_;
107 0         0 my $proc = $self->{proc};
108 0         0 chomp($msg);
109 0         0 $proc->msg($msg);
110             }
111              
112             sub warning($)
113             {
114 0     0 0 0 my ($self, $msg) = @_;
115 0         0 my $proc = $self->{proc};
116 0         0 chomp($msg);
117 0         0 $proc->errmsg($msg);
118             }
119              
120             sub awaken($;$) {
121 3     3 0 13 my ($self, $opts) = @_;
122 2     2   17 no warnings 'once';
  2         4  
  2         1415  
123             # Process options
124 3 50 33     36 if (!defined($opts) && $ENV{'TREPANPL_OPTS'}) {
125 0         0 $opts = eval "$ENV{'TREPANPL_OPTS'}";
126             }
127 3         9 $invoke_opts = $opts;
128              
129             # require Data::Dumper;
130             # import Data::Dumper;
131             # print Dumper($opts), "\n";
132              
133 3         9 my $exec_strs_ary = $opts->{exec_strs};
134 3 0 50     13 if (defined $exec_strs_ary && scalar @{$exec_strs_ary}) {
  0         0  
135 0         0 $self->{exec_strs} = $opts->{exec_strs};
136 0         0 $self->{need_e_remap} = 1;
137             }
138              
139 3 50       12 $0 = $opts->{dollar_0} if $opts->{dollar_0};
140              
141 3 50 33     32 $DB::fall_off_on_end = 1 if $opts->{fall_off_end} || $opts->{traceprint};
142              
143 3 50       14 $SIG{__DIE__} = \&DB::catch if $opts->{post_mortem};
144              
145 3         6 my $proc;
146 3         8 my $batch_filename = $opts->{testing};
147 3 50 50     17 if ($opts->{bw} && HAVE_BULLWINKLE) {
148 0         0 my $bw_opts = $opts->{bw};
149 0 0       0 $bw_opts = {} unless ref($bw_opts) eq 'HASH';
150 0 0       0 if (defined $batch_filename) {
151 0         0 my $fh = IO::File->new($batch_filename, 'r');
152 0         0 $bw_opts = {input => $fh,
153             bw_opts => {
154             echo_read => 1,
155             input_opts => {readline => 0}}
156             };
157             }
158 0         0 $proc = Devel::Trepan::BWProcessor->new(undef, $self, $bw_opts);
159             } else {
160 3 50       16 $batch_filename = $opts->{batchfile} unless defined $batch_filename;
161 3         13 my %cmdproc_opts = ();
162 3         10 for my $field
163             (qw(basename cmddir highlight readline traceprint)) {
164             # print "field $field $opts->{$field}\n";
165 15         41 $cmdproc_opts{$field} = $opts->{$field};
166             }
167              
168 3 50       13 if (defined $batch_filename) {
169 0         0 my $result = Devel::Trepan::Util::invalid_filename($batch_filename);
170 0 0       0 if (defined $result) {
171 0         0 print STDERR "$result\n"
172             } else {
173 0         0 my $output = Devel::Trepan::IO::Output->new;
174             my $script_opts =
175 0 0       0 $opts->{testing} ? {abort_on_error => 0} : {};
176 0         0 my $script_intf =
177             Devel::Trepan::Interface::Script->new($batch_filename,
178             $output,
179             $script_opts);
180 0         0 $proc = Devel::Trepan::CmdProcessor->new([$script_intf],
181             $self,
182             \%cmdproc_opts);
183 0         0 $self->{proc} = $proc;
184 0         0 $main::TREPAN_CMDPROC = $self->{proc};
185             }
186             } else {
187 3         8 my $intf = undef;
188 3 50 66     33 if (defined($dbgr) && exists($dbgr->{proc})) {
189 1         20 $intf = $dbgr->{proc}{interfaces};
190             $intf->[-1]{input}{term_readline} = $opts->{readline} if
191 1 50       9 exists($opts->{readline});
192             }
193 3 50       15 if ($opts->{server}) {
194 0         0 my $server_opts = $opts->{server};
195 0 0       0 if ($server_opts->[0] eq 'tcp') {
    0          
    0          
196             $server_opts = {
197             io => 'tcp',
198             host => $opts->{host},
199             port => $opts->{port},
200 0         0 logger => *STDOUT
201             };
202             } elsif ($server_opts->[0] eq 'fifo') {
203 0         0 $server_opts = {
204             io => 'fifo',
205             logger => *STDOUT
206             };
207             } elsif ($server_opts->[0] eq 'tty') {
208 0         0 $server_opts = {
209             io => 'tty',
210             logger => *STDOUT
211             }
212             } else {
213 0         0 die "Unknown server protocol: $server_opts->[0]";
214             }
215 0         0 $intf = [
216             Devel::Trepan::Interface::Server->new(undef, undef,
217             $server_opts)
218             ];
219             }
220 3         43 $proc = Devel::Trepan::CmdProcessor->new($intf, $self,
221             \%cmdproc_opts);
222 3         22 $main::TREPAN_CMDPROC = $self->{proc};
223 3 50       14 $opts = {} unless defined $opts;
224              
225 3         8 for my $startup_file (@{$opts->{cmdfiles}}) {
  3         22  
226 0         0 add_startup_files($proc, $startup_file);
227             }
228 3 50 33     30 if (!$opts->{nx} && exists $opts->{initfile}) {
229 0         0 add_startup_files($proc, $opts->{initfile}, 1);
230             }
231             }
232 3 50       13 $proc->{skip_count} = -1 if $opts->{traceprint};
233             }
234 3         11 $self->{proc} = $proc;
235             $self->{sigmgr} =
236 0     0     Devel::Trepan::SigMgr->new(sub{ $DB::running = 0; $DB::single = 0;
  0            
237 0           $self->signal_handler(@_) },
238 0     0     sub {$proc->msg(@_)},
239 0     0     sub {$proc->errmsg(@_)},
240 3     0   61 sub {$proc->section(@_)});
  0            
241             }
242              
243             sub display_lists ($)
244             {
245 0     0 0   my $self = shift;
246 0           return $self->{proc}{displays}{list};
247             }
248              
249             # Restore the value of $0 that we had when we came in here.
250             # See above for why we have to save and restore $0.
251             $0 = $dollar0_save;
252              
253             END {
254 2     2   1318 $DB::ready = 0;
255             };
256              
257             # FIXME: remove the next line and make this really OO.
258             $dbgr = __PACKAGE__->new();
259              
260             1;